diff --git a/llvm-general.cabal b/llvm-general.cabal --- a/llvm-general.cabal +++ b/llvm-general.cabal @@ -1,5 +1,5 @@ name: llvm-general -version: 3.3.0.1 +version: 3.3.0.2 license: BSD3 license-file: LICENSE author: Benjamin S.Scarlet @@ -34,12 +34,16 @@ type: git location: git://github.com/bscarlet/llvm-general.git branch: llvm-3.3 - tag: v3.3.0.1 + tag: v3.3.0.2 flag shared-llvm description: link against llvm shared rather than static library default: False +flag debug + description: compile C(++) shims with debug info for ease of troubleshooting + default: False + library build-tools: llvm-config ghc-options: -fwarn-unused-imports @@ -172,6 +176,9 @@ src/LLVM/General/Internal/FFI/TargetC.cpp src/LLVM/General/Internal/FFI/TypeC.cpp src/LLVM/General/Internal/FFI/ValueC.cpp + + if flag(debug) + cc-options: -g test-suite test type: exitcode-stdio-1.0 diff --git a/src/LLVM/General/Internal/Instruction.hs b/src/LLVM/General/Internal/Instruction.hs --- a/src/LLVM/General/Internal/Instruction.hs +++ b/src/LLVM/General/Internal/Instruction.hs @@ -4,7 +4,8 @@ TupleSections, MultiParamTypeClasses, FlexibleContexts, - FlexibleInstances + FlexibleInstances, + UndecidableInstances #-} module LLVM.General.Internal.Instruction where @@ -333,9 +334,10 @@ ] ) - instance EncodeM EncodeAST A.Instruction (Ptr FFI.Instruction) where + instance EncodeM EncodeAST A.Instruction (Ptr FFI.Instruction, EncodeAST ()) where encodeM o = scopeAnyCont $ do builder <- gets encodeStateBuilder + let return' i = return (FFI.upCast i, return ()) s <- encodeM "" $( [| @@ -350,7 +352,7 @@ op1' <- encodeM op1 pred <- encodeM pred i <- liftIO $ FFI.buildICmp builder pred op0' op1' s - return $ FFI.upCast i + return' i A.FCmp { A.fpPredicate = pred, A.operand0 = op0, @@ -361,16 +363,18 @@ op1' <- encodeM op1 pred <- encodeM pred i <- liftIO $ FFI.buildFCmp builder pred op0' op1' s - return $ FFI.upCast i + return' i A.Phi { A.type' = t, A.incomingValues = ivs } -> do t' <- encodeM t i <- liftIO $ FFI.buildPhi builder t' s - defer - let (ivs3, bs3) = unzip ivs - ivs3' <- encodeM ivs3 - bs3' <- encodeM bs3 - liftIO $ FFI.addIncoming i ivs3' bs3' - return $ FFI.upCast i + return ( + FFI.upCast i, + do + let (ivs3, bs3) = unzip ivs + ivs3' <- encodeM ivs3 + bs3' <- encodeM bs3 + liftIO $ FFI.addIncoming i ivs3' bs3' + ) A.Call { A.isTailCall = tc, A.callingConvention = cc, @@ -394,46 +398,46 @@ liftIO $ FFI.setTailCall i tc cc <- encodeM cc liftIO $ FFI.setInstructionCallConv i cc - return $ FFI.upCast i + return' i A.Select { A.condition' = c, A.trueValue = t, A.falseValue = f } -> do c' <- encodeM c t' <- encodeM t f' <- encodeM f i <- liftIO $ FFI.buildSelect builder c' t' f' s - return $ FFI.upCast i + return' i A.VAArg { A.argList = al, A.type' = t } -> do al' <- encodeM al t' <- encodeM t i <- liftIO $ FFI.buildVAArg builder al' t' s - return $ FFI.upCast i + return' i A.ExtractElement { A.vector = v, A.index = idx } -> do v' <- encodeM v idx' <- encodeM idx i <- liftIO $ FFI.buildExtractElement builder v' idx' s - return $ FFI.upCast i + return' i A.InsertElement { A.vector = v, A.element = e, A.index = idx } -> do v' <- encodeM v e' <- encodeM e idx' <- encodeM idx i <- liftIO $ FFI.buildInsertElement builder v' e' idx' s - return $ FFI.upCast i + return' i A.ShuffleVector { A.operand0 = o0, A.operand1 = o1, A.mask = mask } -> do o0' <- encodeM o0 o1' <- encodeM o1 mask' <- encodeM mask i <- liftIO $ FFI.buildShuffleVector builder o0' o1' mask' s - return $ FFI.upCast i + return' i A.ExtractValue { A.aggregate = a, A.indices' = is } -> do a' <- encodeM a (n, is') <- encodeM is i <- liftIO $ FFI.buildExtractValue builder a' is' n s - return $ FFI.upCast i + return' i A.InsertValue { A.aggregate = a, A.element = e, A.indices' = is } -> do a' <- encodeM a e' <- encodeM e (n, is') <- encodeM is i <- liftIO $ FFI.buildInsertValue builder a' e' is' n s - return $ FFI.upCast i + return' i A.LandingPad { A.type' = t, A.personalityFunction = pf, @@ -458,13 +462,13 @@ when cl $ do cl <- encodeM cl liftIO $ FFI.setCleanup i cl - return $ FFI.upCast i + return' i A.Alloca { A.allocatedType = alt, A.numElements = n, A.alignment = alignment } -> do alt' <- encodeM alt n' <- maybe (return nullPtr) encodeM n i <- liftIO $ FFI.buildAlloca builder alt' n' s unless (alignment == 0) $ liftIO $ FFI.setInstrAlignment i (fromIntegral alignment) - return $ FFI.upCast i + return' i A.Load { A.volatile = vol, A.address = a, @@ -477,7 +481,7 @@ vol <- encodeM vol (ss, mo) <- encodeM mat i <- liftIO $ FFI.buildLoad builder a' al vol mo ss s - return $ FFI.upCast i + return' i A.Store { A.volatile = vol, A.address = a, @@ -492,7 +496,7 @@ vol <- encodeM vol (ss, mo) <- encodeM mat i <- liftIO $ FFI.buildStore builder v' a' al vol mo ss s - return $ FFI.upCast i + return' i A.GetElementPtr { A.address = a, A.indices = is, A.inBounds = ib } -> do a' <- encodeM a (n, is') <- encodeM is @@ -500,11 +504,11 @@ when ib $ do ib <- encodeM ib liftIO $ FFI.setInBounds i ib - return $ FFI.upCast i + return' i A.Fence { A.atomicity = at } -> do (ss, mo) <- encodeM at i <- liftIO $ FFI.buildFence builder mo ss s - return $ FFI.upCast i + return' i A.CmpXchg { A.volatile = vol, A.address = a, A.expected = e, A.replacement = r, @@ -517,7 +521,7 @@ vol <- encodeM vol (ss, mo) <- encodeM at i <- liftIO $ FFI.buildCmpXchg builder a' e' r' vol mo ss s - return $ FFI.upCast i + return' i A.AtomicRMW { A.volatile = vol, A.rmwOperation = rmwOp, @@ -532,7 +536,7 @@ vol <- encodeM vol (ss, mo) <- encodeM at i <- liftIO $ FFI.buildAtomicRMW builder rmwOp a' v' vol mo ss s - return $ FFI.upCast i + return' i o -> $( let fieldData :: String -> [Either TH.ExpQ TH.ExpQ] @@ -584,7 +588,7 @@ let s = TH.nameBase f, Right action <- fieldData s ] ++ [ - TH.noBindS [| return $ FFI.upCast $(TH.dyn "i") |] + TH.noBindS [| return' $(TH.dyn "i") |] ] ) ] @@ -610,5 +614,15 @@ liftIO $ FFI.setValueName v n' defineLocal n v return i + +instance EncodeM EncodeAST a (Ptr FFI.Instruction, EncodeAST ()) => EncodeM EncodeAST (A.Named a) (EncodeAST ()) where + encodeM (A.Do o) = liftM snd $ (encodeM o :: EncodeAST (Ptr FFI.Instruction, EncodeAST ())) + encodeM (n A.:= o) = do + (i, later) <- encodeM o + let v = FFI.upCast (i :: Ptr FFI.Instruction) + n' <- encodeM n + liftIO $ FFI.setValueName v n' + defineLocal n v + return later diff --git a/src/LLVM/General/Internal/Module.hs b/src/LLVM/General/Internal/Module.hs --- a/src/LLVM/General/Internal/Module.hs +++ b/src/LLVM/General/Internal/Module.hs @@ -42,6 +42,7 @@ import LLVM.General.Internal.Operand import LLVM.General.Internal.Type import LLVM.General.Internal.Value +import LLVM.General.Internal.Instruction () import LLVM.General.Diagnostic @@ -68,6 +69,7 @@ moduleString :: Module -> IO String moduleString (Module m) = bracket (FFI.getModuleAssembly m) free $ decodeM +-- | generate LLVM bitcode from a 'Module' writeBitcodeToFile :: FilePath -> Module -> IO () writeBitcodeToFile path (Module m) = flip runAnyContT return $ do msgPtr <- alloca @@ -190,11 +192,15 @@ liftIO $ FFI.addAttribute p attrs return () return () - forInterleavedM blocks $ \(A.BasicBlock bName namedInstrs term) -> do + finishInstrs <- forInterleavedM blocks $ \(A.BasicBlock bName namedInstrs term) -> do b <- encodeM bName - (do builder <- gets encodeStateBuilder; liftIO $ FFI.positionBuilderAtEnd builder b) - (mapM encodeM namedInstrs :: EncodeAST [Ptr FFI.Instruction]) - encodeM term :: EncodeAST (Ptr FFI.Instruction) + (do + builder <- gets encodeStateBuilder + liftIO $ FFI.positionBuilderAtEnd builder b) + finishes <- mapM encodeM namedInstrs :: EncodeAST [EncodeAST ()] + (encodeM term :: EncodeAST (Ptr FFI.Instruction)) + return (sequence_ finishes) + sequence_ finishInstrs return (FFI.upCast f) setLinkage g' (A.G.linkage g) setVisibility g' (A.G.visibility g) diff --git a/test/LLVM/General/Test/Module.hs b/test/LLVM/General/Test/Module.hs --- a/test/LLVM/General/Test/Module.hs +++ b/test/LLVM/General/Test/Module.hs @@ -250,7 +250,58 @@ ] ] t <- withModuleFromAST context ast $ \_ -> return True - t @?= Right True + t @?= Right True, + + testCase "Phi node finishes" $ withContext $ \context -> do + let ast = Module "" Nothing Nothing [ + GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([ + Parameter (IntegerType 32) (Name "x") [] + ],False) + [] Nothing 0 + [ + BasicBlock (UnName 0) [ + UnName 1 := Mul { + nsw = True, + nuw = False, + operand0 = LocalReference (Name "x"), + operand1 = LocalReference (Name "x"), + metadata = [] + } + ] ( + Do $ Br (Name "here") [] + ), + BasicBlock (Name "here") [ + UnName 2 := Phi (IntegerType 32) [ (ConstantOperand (C.Int 32 42), UnName 0) ] [] + ] ( + Do $ Br (Name "elsewhere") [] + ), + BasicBlock (Name "elsewhere") [ + ] ( + Do $ Br (Name "there") [] + ), + BasicBlock (Name "there") [ + ] ( + Do $ Ret (Just (LocalReference (UnName 1))) [] + ) + ] + ] + s = "; ModuleID = ''\n\ + \\n\ + \define i32 @foo(i32 %x) {\n\ + \ %1 = mul nsw i32 %x, %x\n\ + \ br label %here\n\ + \\n\ + \here: ; preds = %0\n\ + \ %2 = phi i32 [ 42, %0 ]\n\ + \ br label %elsewhere\n\ + \\n\ + \elsewhere: ; preds = %here\n\ + \ br label %there\n\ + \\n\ + \there: ; preds = %elsewhere\n\ + \ ret i32 %1\n\ + \}\n" + strCheck ast s ], testGroup "failures" [ diff --git a/test/LLVM/General/Test/Tests.hs b/test/LLVM/General/Test/Tests.hs --- a/test/LLVM/General/Test/Tests.hs +++ b/test/LLVM/General/Test/Tests.hs @@ -13,7 +13,6 @@ import qualified LLVM.General.Test.Optimization as Optimization import qualified LLVM.General.Test.Target as Target - tests = testGroup "llvm-general" [ Constants.tests, DataLayout.tests,