packages feed

llvm-general 3.2.4.1 → 3.2.4.2

raw patch · 21 files changed

+203/−76 lines, 21 files

Files

llvm-general.cabal view
@@ -1,5 +1,5 @@ name: llvm-general-version: 3.2.4.1+version: 3.2.4.2 license: BSD3 license-file: LICENSE author: Benjamin S.Scarlet <fgthb0@greynode.net>@@ -16,14 +16,15 @@ 	handles almost all of the stateful complexities of using the LLVM API to build IR; and it supports moving IR not 	only from Haskell into LLVM C++ objects, but the other direction - from LLVM C++ into Haskell. extra-source-files:+  src/LLVM/General/Internal/FFI/Analysis.h+  src/LLVM/General/Internal/FFI/Function.h+  src/LLVM/General/Internal/FFI/GlobalValue.h+  src/LLVM/General/Internal/FFI/InlineAssembly.h   src/LLVM/General/Internal/FFI/Instruction.h-  src/LLVM/General/Internal/FFI/Value.h   src/LLVM/General/Internal/FFI/SMDiagnostic.h-  src/LLVM/General/Internal/FFI/InlineAssembly.h   src/LLVM/General/Internal/FFI/Target.h-  src/LLVM/General/Internal/FFI/Function.h-  src/LLVM/General/Internal/FFI/GlobalValue.h   src/LLVM/General/Internal/FFI/Type.h+  src/LLVM/General/Internal/FFI/Value.h     source-repository head   type: git@@ -33,7 +34,7 @@   type: git   location: git://github.com/bscarlet/llvm-general.git   branch: llvm-3.2-  tag: v3.2.4.1+  tag: v3.2.4.2  flag shared-llvm   description: link against llvm shared rather than static library@@ -86,6 +87,7 @@     LLVM.General.AST.RMWOperation     LLVM.General.AST.Type     LLVM.General.AST.Visibility+    LLVM.General.Analysis     LLVM.General.CodeGenOpt     LLVM.General.CodeModel     LLVM.General.CommandLine@@ -103,6 +105,7 @@     Control.Monad.AnyCont     Control.Monad.AnyCont.Class     Control.Monad.Trans.AnyCont+    LLVM.General.Internal.Analysis     LLVM.General.Internal.Atomicity     LLVM.General.Internal.Attribute     LLVM.General.Internal.BasicBlock@@ -132,6 +135,7 @@     LLVM.General.Internal.Target     LLVM.General.Internal.Type     LLVM.General.Internal.Value+    LLVM.General.Internal.FFI.Analysis     LLVM.General.Internal.FFI.Assembly     LLVM.General.Internal.FFI.BasicBlock     LLVM.General.Internal.FFI.BinaryOperator@@ -202,6 +206,7 @@     FlexibleContexts   main-is: Test.hs   other-modules:+    LLVM.General.Test.Analysis     LLVM.General.Test.Constants     LLVM.General.Test.DataLayout     LLVM.General.Test.ExecutionEngine
+ src/LLVM/General/Analysis.hs view
@@ -0,0 +1,8 @@+-- | functionality for analyzing 'LLVM.General.Module.Module's.  Much of the analysis+-- possible with LLVM is managed internally, as needed by 'Transforms', and so is not+-- yet exposed here.+module LLVM.General.Analysis (+  verify+  ) where++import LLVM.General.Internal.Analysis
+ src/LLVM/General/Internal/Analysis.hs view
@@ -0,0 +1,19 @@+module LLVM.General.Internal.Analysis where++import Control.Monad.Error+import Control.Monad.AnyCont++import qualified LLVM.General.Internal.FFI.Analysis as FFI+import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI++import LLVM.General.Internal.Module+import LLVM.General.Internal.Coding++-- | Run basic sanity checks on a 'Module'. Note that the same checks will trigger assertions+-- within LLVM if LLVM was built with them turned on, before this function can be is called.+verify :: Module -> ErrorT String IO ()+verify (Module m) = flip runAnyContT return $ do+  errorPtr <- alloca+  result <- decodeM =<< (liftIO $ FFI.verifyModule m FFI.verifierFailureActionReturnStatus errorPtr)+  when result $ fail =<< decodeM errorPtr+
src/LLVM/General/Internal/EncodeAST.hs view
@@ -18,7 +18,6 @@  import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI import qualified LLVM.General.Internal.FFI.Builder as FFI-import qualified LLVM.General.Internal.FFI.Type as FFI  import qualified LLVM.General.AST as A
+ src/LLVM/General/Internal/FFI/Analysis.h view
@@ -0,0 +1,11 @@+#ifndef __LLVM_GENERAL_INTERNAL_FFI__ANALYSIS__H__+#define __LLVM_GENERAL_INTERNAL_FFI__ANALYSIS__H__++#include "llvm-c/Analysis.h"++#define LLVM_GENERAL_FOR_EACH_VERIFIER_FAILURE_ACTION(macro) \+	macro(AbortProcess) \+	macro(PrintMessage) \+	macro(ReturnStatus)++#endif
+ src/LLVM/General/Internal/FFI/Analysis.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE+  ForeignFunctionInterface+  #-}+module LLVM.General.Internal.FFI.Analysis where++import Foreign.Ptr+import Foreign.C++import LLVM.General.Internal.FFI.LLVMCTypes+import LLVM.General.Internal.FFI.Module++foreign import ccall unsafe "LLVMVerifyModule" verifyModule ::+  Ptr Module -> VerifierFailureAction -> Ptr MallocedCString -> IO LLVMBool
src/LLVM/General/Internal/FFI/BinaryOperator.hs view
@@ -13,11 +13,6 @@ import LLVM.General.Internal.FFI.PtrHierarchy import LLVM.General.Internal.FFI.LLVMCTypes --- | a blind type to correspond to llvm::BinaryOperator-data BinaryOperator--instance ChildOf Instruction BinaryOperator- foreign import ccall unsafe "LLVMIsABinaryOperator" isABinaryOperator ::     Ptr Value -> IO (Ptr BinaryOperator)
src/LLVM/General/Internal/FFI/Builder.hs view
@@ -1,16 +1,17 @@ {-#   LANGUAGE   ForeignFunctionInterface,-  TemplateHaskell+  TemplateHaskell,+  ViewPatterns   #-} -- | FFI glue for llvm::IRBuilder - llvm's IR construction state object module LLVM.General.Internal.FFI.Builder where  import qualified Language.Haskell.TH as TH +import Control.Monad+ import qualified LLVM.General.AST.Instruction as A-import qualified LLVM.General.AST.Operand as A-import qualified LLVM.General.AST.Type as A  import LLVM.General.Internal.InstructionDefs as ID @@ -19,10 +20,9 @@  import qualified Data.Map as Map -import LLVM.General.Internal.FFI.LLVMCTypes+import LLVM.General.Internal.FFI.Cleanup import LLVM.General.Internal.FFI.Context-import LLVM.General.Internal.FFI.BinaryOperator-import LLVM.General.Internal.FFI.Type+import LLVM.General.Internal.FFI.LLVMCTypes import LLVM.General.Internal.FFI.PtrHierarchy  data Builder@@ -64,29 +64,23 @@   $(do-  sequence [-     TH.forImpD TH.cCall TH.unsafe cName (TH.mkName ("build" ++ a)) [t| -       Ptr Builder -> $(foldr (\at rt -> [t| $(at) -> $(rt) |]) [t| CString -> IO (Ptr $(rt)) |] ats)-       |]-     | (lrn, ID.InstructionDef { ID.cAPIName = a, ID.instructionKind = k }) <- Map.toList ID.instructionDefs,-       let fieldTypes = -             (\(TH.RecC _ fs) -> [ t | (_,_,t) <- fs]) $-             Map.findWithDefault -                  (error $ "LLVM instruction not found in AST: " ++ show lrn)-                  lrn ID.astInstructionRecs-           ats = flip concatMap fieldTypes $ \ft ->-                 case ft of-                   TH.ConT h | h == ''Bool -> [[t| LLVMBool |]]-                             | h == ''A.Operand -> [[t| Ptr Value |]]-                             | h == ''A.Type -> [[t| Ptr Type |]]-                             | h == ''A.InstructionMetadata -> []-                   _ -> error $ "show ft = " ++ show ft-           cName = (if TH.ConT ''Bool `elem` fieldTypes then "LLVM_General_" else "LLVM") ++ "Build" ++ a,-       rt <- case k of-               ID.Binary -> [[t| BinaryOperator |]]-               ID.Cast -> [[t| Instruction |]]-               _ -> []-    ]+  liftM concat $ sequence $ do+    let instrInfo = ID.outerJoin ID.astInstructionRecs ID.instructionDefs+    (lrn, ii) <- Map.toList instrInfo+    (TH.RecC _ (unzip3 -> (_, _, fieldTypes)), ID.InstructionDef { ID.cAPIName = a, ID.instructionKind = k }) <- case ii of+      (Just r, Just d) -> return (r,d)+      (Just _, Nothing) -> error $ "An AST instruction was not found in the LLVM instruction defs"+      (Nothing, Just ID.InstructionDef { ID.instructionKind = k }) | k /= ID.Terminator -> +        error $ "LLVM instruction def " ++ lrn ++ " not found in the AST"+      _ -> []++    let ats = map typeMapping [ t | t <- fieldTypes, t /= TH.ConT ''A.InstructionMetadata ]+        cName = (if hasFlags fieldTypes then "LLVM_General_" else "LLVM") ++ "Build" ++ a+    rt <- case k of+            ID.Binary -> [[t| BinaryOperator |]]+            ID.Cast -> [[t| Instruction |]]+            _ -> []+    return $ foreignDecl cName ("build" ++ a) ([[t| Ptr Builder |]] ++ ats ++ [[t| CString |]]) [t| Ptr $(rt) |]  )  foreign import ccall unsafe "LLVMBuildArrayAlloca" buildAlloca ::
src/LLVM/General/Internal/FFI/Cleanup.hs view
@@ -8,16 +8,19 @@ import Data.Sequence as Seq import Data.Foldable (toList) -import Data.Function--import LLVM.General.Internal.FFI.LLVMCTypes import Data.Word import Data.Int import Foreign.C import Foreign.Ptr +import LLVM.General.Internal.FFI.LLVMCTypes+import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI+ import qualified LLVM.General.AST.IntegerPredicate as A (IntegerPredicate)  import qualified LLVM.General.AST.FloatingPointPredicate as A (FloatingPointPredicate) +import qualified LLVM.General.AST.Constant as A.C (Constant)+import qualified LLVM.General.AST.Operand as A (Operand)+import qualified LLVM.General.AST.Type as A (Type)  foreignDecl :: String -> String -> [TypeQ] -> TypeQ -> DecsQ foreignDecl cName hName argTypeQs returnTypeQ = do@@ -59,15 +62,22 @@     ]    ] -typeMappingU :: (Type -> TypeQ) -> Type -> TypeQ-typeMappingU typeMapping t = case t of+-- | The LLVM C-API for instructions with boolean flags (e.g. nsw) is weak, so they get+-- separated out for different handling. This check is an accurate but crude test for whether+-- an instruction needs such handling. As such it may need revision in the future (if has-a-boolean-member+-- is no longer the same as needs-special-handling).+hasFlags :: [Type] -> Bool+hasFlags = any (== ConT ''Bool)++typeMapping :: Type -> TypeQ+typeMapping t = case t of   ConT h | h == ''Bool -> [t| LLVMBool |]          | h == ''Int32 -> [t| CInt |]          | h == ''Word32 -> [t| CUInt |]          | h == ''String -> [t| CString |]+         | h == ''A.Operand -> [t| Ptr FFI.Value |]+         | h == ''A.Type -> [t| Ptr FFI.Type |]+         | h == ''A.C.Constant -> [t| Ptr FFI.Constant |]          | h == ''A.FloatingPointPredicate -> [t| FCmpPredicate |]          | h == ''A.IntegerPredicate -> [t| ICmpPredicate |]   AppT ListT x -> foldl1 appT [tupleT 2, [t| CUInt |], appT [t| Ptr |] (typeMapping x)]--typeMapping :: Type -> TypeQ-typeMapping = fix typeMappingU
src/LLVM/General/Internal/FFI/Constant.hs view
@@ -3,17 +3,16 @@   ForeignFunctionInterface,   MultiParamTypeClasses,   UndecidableInstances,-  OverlappingInstances+  OverlappingInstances,+  ViewPatterns   #-} -- | FFI functions for handling the LLVM Constant class module LLVM.General.Internal.FFI.Constant where  import qualified Language.Haskell.TH as TH import qualified LLVM.General.Internal.InstructionDefs as ID-import qualified LLVM.General.AST.Constant as A.C  import Control.Monad-import Data.Function import qualified Data.Map as Map import Data.Word @@ -23,7 +22,6 @@ import LLVM.General.Internal.FFI.PtrHierarchy import LLVM.General.Internal.FFI.Context import LLVM.General.Internal.FFI.Cleanup-import LLVM.General.Internal.FFI.Type import LLVM.General.Internal.FFI.LLVMCTypes  foreign import ccall unsafe "LLVMIsConstant" isConstant ::@@ -90,18 +88,14 @@  $(do    let constExprInfo = ID.innerJoin (ID.innerJoin ID.astConstantRecs ID.astInstructionRecs) ID.instructionDefs-   let tm = fix tm' -         where tm' _ (TH.ConT h) | h == ''A.C.Constant = [t| Ptr Constant |]-               tm' x t = typeMappingU x t    liftM concat $ sequence $ do-     (name, ((TH.RecC _ fs,_), ID.InstructionDef { ID.instructionKind = ik })) <- Map.toList constExprInfo-     let hasFlags = any (== ''Bool) [ h | (_, _, TH.ConT h) <- fs ]+     (name, ((TH.RecC _ (unzip3 -> (_, _, fieldTypes)),_), ID.InstructionDef { ID.instructionKind = ik })) <- Map.toList constExprInfo      prefix <- case ik of                  ID.Other -> return "LLVM"-                 ID.Binary | hasFlags -> return "LLVM_General_"+                 ID.Binary | hasFlags fieldTypes -> return "LLVM_General_"                  _ -> []      return $-       foreignDecl (prefix ++ "Const" ++ name) ("constant" ++ name) [tm t | (_, _, t) <- fs ] [t| Ptr Constant |]+       foreignDecl (prefix ++ "Const" ++ name) ("constant" ++ name) (map typeMapping fieldTypes) [t| Ptr Constant |]   )  foreign import ccall unsafe "LLVMConstGEP" constantGetElementPtr' ::
src/LLVM/General/Internal/FFI/InlineAssembly.hs view
@@ -9,7 +9,6 @@  import LLVM.General.Internal.FFI.LLVMCTypes import LLVM.General.Internal.FFI.PtrHierarchy-import LLVM.General.Internal.FFI.Type  foreign import ccall unsafe "LLVMIsAInlineAsm" isAInlineAsm ::   Ptr Value -> IO (Ptr InlineAsm)
src/LLVM/General/Internal/FFI/Instruction.hs view
@@ -12,7 +12,6 @@ import Foreign.C  import LLVM.General.Internal.FFI.PtrHierarchy-import LLVM.General.Internal.FFI.Type import LLVM.General.Internal.FFI.LLVMCTypes  foreign import ccall unsafe "LLVMIsAInstruction" isAInstruction ::
src/LLVM/General/Internal/FFI/LLVMCTypes.hsc view
@@ -17,6 +17,7 @@ #include "LLVM/General/Internal/FFI/Function.h" #include "LLVM/General/Internal/FFI/GlobalValue.h" #include "LLVM/General/Internal/FFI/Type.h"+#include "LLVM/General/Internal/FFI/Analysis.h"  import Language.Haskell.TH.Quote @@ -184,3 +185,8 @@   deriving (Eq, Read, Show, Bits, Typeable, Data, Num) #define FA_Rec(n,a) { #n, LLVM ## n ## a }, #{inject FUNCTION_ATTR, FunctionAttr, FunctionAttr, functionAttr, FA_Rec}++newtype VerifierFailureAction = VerifierFailureAction CUInt+  deriving (Eq, Read, Show, Bits, Typeable, Data, Num)+#define VFA_Rec(n) { #n, LLVM ## n ## Action },+#{inject VERIFIER_FAILURE_ACTION, VerifierFailureAction, VerifierFailureAction, verifierFailureAction, VFA_Rec}
src/LLVM/General/Internal/FFI/Module.hs view
@@ -9,7 +9,6 @@ import LLVM.General.Internal.FFI.Context import LLVM.General.Internal.FFI.LLVMCTypes import LLVM.General.Internal.FFI.PtrHierarchy-import LLVM.General.Internal.FFI.Type  data Module
src/LLVM/General/Internal/FFI/PassManager.hs view
@@ -5,7 +5,7 @@  module LLVM.General.Internal.FFI.PassManager where -import Language.Haskell.TH+import qualified Language.Haskell.TH as TH  import Control.Monad @@ -45,22 +45,22 @@     Ptr PassManager -> IO CUInt  $(do-  let declareForeign :: Name -> [Type] -> DecsQ+  let declareForeign :: TH.Name -> [TH.Type] -> TH.DecsQ       declareForeign hName extraParams = do-        let n = nameBase hName+        let n = TH.nameBase hName         foreignDecl            (cName n)           ("add" ++ n ++ "Pass")           ([[t| Ptr PassManager |]]             ++ [[t| Ptr TargetLowering |] | needsTargetLowering n]            ++ map typeMapping extraParams)-          (tupleT 0)+          (TH.tupleT 0) -  TyConI (DataD _ _ _ cons _) <- reify ''G.Pass+  TH.TyConI (TH.DataD _ _ _ cons _) <- TH.reify ''G.Pass   liftM concat $ forM cons $ \con -> case con of-    RecC n l -> declareForeign n [ t | (_,_,t) <- l ]-    NormalC n [] -> declareForeign n []-    NormalC n _ -> error "pass descriptor constructors with fields need to be records"+    TH.RecC n l -> declareForeign n [ t | (_,_,t) <- l ]+    TH.NormalC n [] -> declareForeign n []+    TH.NormalC n _ -> error "pass descriptor constructors with fields need to be records"  )  data PassManagerBuilder
src/LLVM/General/Internal/FFI/PtrHierarchy.hs view
@@ -68,6 +68,11 @@  instance ChildOf User Instruction +-- | <http://llvm.org/doxygen/classllvm_1_1BinaryOperator.html>+data BinaryOperator++instance ChildOf Instruction BinaryOperator+ -- | <http://llvm.org/doxygen/classllvm_1_1User.html> data User @@ -90,3 +95,7 @@ data InlineAsm  instance ChildOf Value InlineAsm++-- | <http://llvm.org/doxygen/classllvm_1_1Type.html>+data Type+
src/LLVM/General/Internal/FFI/Type.hs view
@@ -10,9 +10,7 @@  import LLVM.General.Internal.FFI.LLVMCTypes import LLVM.General.Internal.FFI.Context---- | a blind type to correspond to llvm::Type-data Type+import LLVM.General.Internal.FFI.PtrHierarchy  -- | <http://llvm.org/doxygen/group__LLVMCCoreType.html#ga112756467f0988613faa6043d674d843> foreign import ccall unsafe "LLVMGetTypeKind" getTypeKind ::
src/LLVM/General/Internal/FFI/Value.hs view
@@ -11,7 +11,6 @@ import Foreign.C  import LLVM.General.Internal.FFI.LLVMCTypes-import LLVM.General.Internal.FFI.Type  import LLVM.General.Internal.FFI.PtrHierarchy  -- | <http://llvm.org/doxygen/group__LLVMCCoreValueGeneral.html#ga12179f46b79de8436852a4189d4451e0>
src/LLVM/General/Internal/Type.hs view
@@ -15,6 +15,7 @@ import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI import LLVM.General.Internal.FFI.LLVMCTypes (typeKindP) import qualified LLVM.General.Internal.FFI.Type as FFI+import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI  import qualified LLVM.General.AST as A import qualified LLVM.General.AST.AddrSpace as A
+ test/LLVM/General/Test/Analysis.hs view
@@ -0,0 +1,67 @@+module LLVM.General.Test.Analysis where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit++import LLVM.General.Test.Support++import Control.Monad.Error++import LLVM.General.Module+import LLVM.General.Context+import LLVM.General.Analysis++import LLVM.General.AST as A+import LLVM.General.AST.Type+import LLVM.General.AST.Name+import LLVM.General.AST.AddrSpace+import LLVM.General.AST.DataLayout+import qualified LLVM.General.AST.IntegerPredicate as IPred+import qualified LLVM.General.AST.Linkage as L+import qualified LLVM.General.AST.Visibility as V+import qualified LLVM.General.AST.CallingConvention as CC+import qualified LLVM.General.AST.Attribute as A+import qualified LLVM.General.AST.Global as G+import qualified LLVM.General.AST.Constant as C++import qualified LLVM.General.Relocation as R+import qualified LLVM.General.CodeModel as CM+import qualified LLVM.General.CodeGenOpt as CGO++tests = testGroup "Analysis" [+  testGroup "Verifier" [+    testCase "Module" $ withContext $ \context -> do+      let ast = Module "<string>" Nothing Nothing [+            GlobalDefinition $ Function L.External V.Default CC.C [] VoidType (Name "foo") ([+                Parameter (IntegerType 32) (Name "x") []+               ],False)+             [] +             Nothing 0         +             [+              BasicBlock (UnName 0) [+                UnName 1 := Call {+                  isTailCall = False,+                  callingConvention = CC.C,+                  returnAttributes = [],+                  function = Right (ConstantOperand (C.GlobalReference (Name "foo"))),+                  arguments = [+                   (ConstantOperand (C.Int 8 1), [])+                  ],+                  functionAttributes = [],+                  metadata = []+                 }+              ] (+                Do $ Ret Nothing []+              )+             ]+            ]+      Left s <- withModuleFromAST' context ast $ runErrorT . verify+      s @?= "Call parameter type does not match function signature!\n\+            \i8 1\n\+            \ i32  call void @foo(i8 1)\n\+            \Broken module found, compilation terminated.\n\+            \Broken module found, compilation terminated.\n"+      | False -- this test will cause an assertion if LLVM is compiled with assertions on.+   ]+ ]
test/LLVM/General/Test/Tests.hs view
@@ -12,6 +12,7 @@ import qualified LLVM.General.Test.Module as Module import qualified LLVM.General.Test.Optimization as Optimization import qualified LLVM.General.Test.Target as Target+import qualified LLVM.General.Test.Analysis as Analysis  tests = testGroup "llvm-general" [     Constants.tests,@@ -23,5 +24,6 @@     Metadata.tests,     Module.tests,     Optimization.tests,-    Target.tests+    Target.tests,+    Analysis.tests   ]