llvm-tf 9.0 → 9.1
raw patch · 15 files changed
+421/−213 lines, 15 filesdep ~llvm-ffi
Dependency ranges changed: llvm-ffi
Files
- example/Arith.hs +1/−1
- example/Array.hs +15/−15
- example/BrainF.hs +1/−1
- llvm-tf.cabal +4/−3
- src/LLVM/Core/CodeGen.hs +6/−6
- src/LLVM/Core/CodeGenMonad.hs +2/−2
- src/LLVM/Core/Instructions.hs +87/−71
- src/LLVM/Core/Instructions/Guided.hs +13/−13
- src/LLVM/Core/Instructions/Private.hs +1/−47
- src/LLVM/Core/Type.hs +68/−29
- src/LLVM/Core/Util.hs +21/−21
- src/LLVM/ExecutionEngine.hs +9/−1
- src/LLVM/ExecutionEngine/Marshal.hs +186/−0
- src/LLVM/ExecutionEngine/Target.hs +3/−1
- src/LLVM/Util/Arithmetic.hs +4/−2
example/Arith.hs view
@@ -80,7 +80,7 @@ x <- load px y <- call f x store y py- ret ()+ ret () vectorPtrWrap :: (Ptr V -> Ptr V -> IO ()) -> V -> IO V vectorPtrWrap f v =
example/Array.hs view
@@ -13,28 +13,28 @@ cg = do dotProd <- createFunction InternalLinkage $ \ size aPtr aStride bPtr bStride -> do r <- forLoop (valueOf 0) size (valueOf 0) $ \ i s -> do- ai <- mul aStride i- bi <- mul bStride i+ ai <- mul aStride i+ bi <- mul bStride i ap <- getElementPtr aPtr (ai, ()) bp <- getElementPtr bPtr (bi, ()) a <- load ap b <- load bp ab <- mul a b add (s :: Value Double) ab- ret r+ ret r let _ = dotProd :: Function (Word32 -> Ptr Double -> Word32 -> Ptr Double -> Word32 -> IO Double) -- multiply a:[n x m], b:[m x l] matMul <- createFunction InternalLinkage $ \ n m l aPtr bPtr cPtr -> do forLoop (valueOf 0) n () $ \ ni () -> do forLoop (valueOf 0) l () $ \ li () -> do- ni' <- mul ni m- row <- getElementPtr aPtr (ni', ())- col <- getElementPtr bPtr (li, ())+ ni' <- mul ni m+ row <- getElementPtr aPtr (ni', ())+ col <- getElementPtr bPtr (li, ()) x <- call dotProd m row (valueOf 1) col m- j <- add ni' li- p <- getElementPtr cPtr (j, ())- store x p+ j <- add ni' li+ p <- getElementPtr cPtr (j, ())+ store x p ret () let _ = matMul :: Function (Word32 -> Word32 -> Word32 -> Ptr Double -> Ptr Double -> Ptr Double -> IO ()) @@ -44,12 +44,12 @@ test <- createNamedFunction ExternalLinkage "test" $ \ x -> do a <- arrayMalloc (4 :: Word32)- fillArray a $ map valueOf [1,2,3,4]- b <- arrayMalloc (4 :: Word32)- fillArray b [x,x,x,x]- c <- arrayMalloc (4 :: Word32)- _ <- call matMul (valueOf 2) (valueOf 2) (valueOf 2) a b c- ret c+ fillArray a $ map valueOf [1,2,3,4]+ b <- arrayMalloc (4 :: Word32)+ fillArray b [x,x,x,x]+ c <- arrayMalloc (4 :: Word32)+ _ <- call matMul (valueOf 2) (valueOf 2) (valueOf 2) a b c+ ret c let _ = test :: Function (Double -> IO (Ptr Double)) return test
example/BrainF.hs view
@@ -138,7 +138,7 @@ return cur gen cur '<' = -- Decrement head.- getElementPtr cur ((-1) :: Word32, ())+ getElementPtr cur (-1 :: Int32, ()) gen cur '>' = -- Increment head. getElementPtr cur (1 :: Word32, ())
llvm-tf.cabal view
@@ -1,5 +1,5 @@ Name: llvm-tf-Version: 9.0+Version: 9.1 License: BSD3 License-File: LICENSE Synopsis: Bindings to the LLVM compiler toolkit using type families.@@ -39,7 +39,7 @@ Location: http://code.haskell.org/~thielema/llvm-tf/ Source-Repository this- Tag: 9.0+ Tag: 9.1 Type: darcs Location: http://code.haskell.org/~thielema/llvm-tf/ @@ -55,7 +55,7 @@ Library Default-Language: Haskell98 Build-Depends:- llvm-ffi >=9.0 && <9.1,+ llvm-ffi >=9.1 && <9.2, tfp >=1.0 && <1.1, transformers >=0.3 && <0.6, storable-record >=0.0.2 && <0.1,@@ -110,6 +110,7 @@ LLVM.Core.UnaryVector LLVM.ExecutionEngine.Engine LLVM.ExecutionEngine.Target+ LLVM.ExecutionEngine.Marshal Executable llvm-align If flag(buildExamples)
src/LLVM/Core/CodeGen.hs view
@@ -282,8 +282,8 @@ defineFunctionParam fn p = do bld <- liftIO $ U.createBuilder let body' = do- newBasicBlock >>= defineBasicBlock- defineParameterized fn p+ newBasicBlock >>= defineBasicBlock+ defineParameterized fn p runCodeGenFunction bld (unValue fn) body' -- | Define a function body. The basic block returned by the function is the function entry point.@@ -307,7 +307,7 @@ -- | Create a new function with the given body. createNamedFunction :: (FunctionArgs f) => Linkage- -> String+ -> String -> FunctionCodeGen f -- ^ Function body. -> CodeGenModule (Function f) createNamedFunction linkage name body = do@@ -581,9 +581,9 @@ elemTyp <- liftIO $ typeRef (LP.Proxy :: LP.Proxy Word8) typ <- liftIO $ FFI.arrayType elemTyp (fromIntegral n) liftIO $ liftM Value $ do g <- U.addGlobal modul InternalLinkage name typ- FFI.setGlobalConstant g FFI.true- FFI.setInitializer g s- return g+ FFI.setGlobalConstant g FFI.true+ FFI.setInitializer g s+ return g --------------------------------------
src/LLVM/Core/CodeGenMonad.hs view
@@ -164,8 +164,8 @@ cgm <- CGM get let cgf = CGFState { cgf_module = cgm, cgf_builder = bld,- cgf_function = fn,- cgf_next = 1 }+ cgf_function = fn,+ cgf_next = 1 } (a, cgf') <- liftIO $ runStateT body cgf CGM $ put (cgf_module cgf') return a
src/LLVM/Core/Instructions.hs view
@@ -85,9 +85,7 @@ FFIBinOp, FFIConstBinOp, GetField, FieldType, GetElementPtr, ElementPtrType, IsIndexArg, IsIndexType, getIxList, getArg,- CmpPredicate(..), IntPredicate(..), FPPredicate(..),- fromIntPredicate, fromFPPredicate,- toIntPredicate, toFPPredicate,+ CmpPredicate(..), uintFromCmpPredicate, sintFromCmpPredicate, fpFromCmpPredicate) import LLVM.Core.Data import LLVM.Core.Type@@ -98,6 +96,7 @@ Value(Value), value, valueOf) import qualified LLVM.FFI.Core as FFI+import LLVM.FFI.Core (IntPredicate(..), FPPredicate(..)) import qualified Type.Data.Num.Decimal.Number as Dec import Type.Data.Num.Decimal.Literal (d1)@@ -105,14 +104,15 @@ import Type.Base.Proxy (Proxy) import Foreign.Ptr (Ptr, FunPtr, )-import Foreign.C (CUInt)+import Foreign.C (CUInt, CInt) import Control.Monad.IO.Class (liftIO) import Control.Monad (liftM) +import qualified Data.Map as Map+import Data.Map (Map) import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word8, Word16, Word32, Word64)-import Data.Map (fromList, (!)) import Prelude hiding (and, or) @@ -185,50 +185,50 @@ -- FIXME: sizeof() does not work for types! --tsize <- FFI.typeOf v -- >>= FFI.sizeOf -- >>= FFI.constIntGetZExtValue >>= return . fromIntegral tsize <- return 1- os <- U.getOperands v >>= mapM getArgDesc- os0 <- if length os > 0 then return $ os !! 0 else return AE- os1 <- if length os > 1 then return $ os !! 1 else return AE- t2 <- (if not (null os) && (opcode >= 30 || opcode <= 41)- then U.getOperands v >>= return . snd . head >>= FFI.typeOf >>= typeDesc2- else return TDVoid)- p <- if opcode `elem` [42, 43] then FFI.cmpInstGetPredicate v else return 0- let instr =- (if opcode >= 8 && opcode <= 25 -- binary arithmetic- then IDBinOp (getBinOp opcode) t os0 os1- else if opcode >= 30 && opcode <= 41 -- conversion- then (getConvOp opcode) t2 t os0- else case opcode of- { 1 -> if null os then IDRetVoid else IDRet t os0;- 2 -> if length os == 1 then IDBrUncond os0 else IDBrCond os0 (os !! 2) os1;- 3 -> IDSwitch $ toPairs os;- -- TODO (can skip for now)- -- 4 -> IndirectBr ; 5 -> Invoke ;- 6 -> IDUnwind; 7 -> IDUnreachable;- 26 -> IDAlloca (getPtrType t) tsize (getImmInt os0);- 27 -> IDLoad t os0; 28 -> IDStore t os0 os1;- 29 -> IDGetElementPtr t os;- 42 -> IDICmp (toIntPredicate p) os0 os1;- 43 -> IDFCmp (toFPPredicate p) os0 os1;- 44 -> IDPhi t $ toPairs os;- -- FIXME: getelementptr arguments are not handled- 45 -> IDCall t (last os) (init os);- 46 -> IDSelect t os0 os1;- -- TODO (can skip for now)- -- 47 -> UserOp1 ; 48 -> UserOp2 ; 49 -> VAArg ;- -- 50 -> ExtractElement ; 51 -> InsertElement ; 52 -> ShuffleVector ;- -- 53 -> ExtractValue ; 54 -> InsertValue ;- _ -> IDInvalidOp })+ ovs <- U.getOperands v+ os <- mapM getArgDesc ovs+ os0 <- return $ case os of {o:_ -> o; _ -> AE}+ os1 <- return $ case os of {_:o:_ -> o; _ -> AE}+ instr <-+ case Map.lookup opcode binOpMap of -- binary arithmetic+ Just op -> return $ IDBinOp op t os0 os1+ Nothing ->+ case Map.lookup opcode convOpMap of+ Just op -> do+ t2 <-+ case ovs of+ (_name,ov):_ -> FFI.typeOf ov >>= typeDesc2+ _ -> return TDVoid+ return $ op t2 t os0+ Nothing ->+ case opcode of+ 1 -> return $ if null os then IDRetVoid else IDRet t os0+ 2 -> return $ if length os == 1 then IDBrUncond os0 else IDBrCond os0 (os !! 2) os1+ 3 -> return $ IDSwitch $ toPairs os+ -- TODO (can skip for now)+ -- 4 -> return IndirectBr ; 5 -> return Invoke+ 6 -> return IDUnwind; 7 -> return IDUnreachable+ 26 -> return $ IDAlloca (getPtrType t) tsize (getImmInt os0)+ 27 -> return $ IDLoad t os0; 28 -> return $ IDStore t os0 os1+ 29 -> return $ IDGetElementPtr t os+ 42 -> do+ pInt <- FFI.cmpInstGetIntPredicate v+ return $ IDICmp (FFI.toIntPredicate pInt) os0 os1+ 43 -> do+ pFloat <- FFI.cmpInstGetRealPredicate v+ return $ IDFCmp (FFI.toRealPredicate pFloat) os0 os1+ 44 -> return $ IDPhi t $ toPairs os+ -- FIXME: getelementptr arguments are not handled+ 45 -> return $ IDCall t (last os) (init os)+ 46 -> return $ IDSelect t os0 os1+ -- TODO (can skip for now)+ -- 47 -> return UserOp1 ; 48 -> return UserOp2 ; 49 -> return VAArg+ -- 50 -> return ExtractElement ; 51 -> return InsertElement ; 52 -> return ShuffleVector+ -- 53 -> return ExtractValue ; 54 -> return InsertValue+ _ -> return IDInvalidOp return (valueName, instr) --if instr /= InvalidOp then return instr else fail $ "Invalid opcode: " ++ show opcode- where getBinOp o = fromList [(8, BOAdd), (9, BOFAdd), (10, BOSub), (11, BOFSub),- (12, BOMul), (13, BOFMul), (14, BOUDiv), (15, BOSDiv),- (16, BOFDiv), (17, BOURem), (18, BOSRem), (19, BOFRem),- (20, BOShL), (21, BOLShR), (22, BOAShR), (23, BOAnd),- (24, BOOr), (25, BOXor)] ! o- getConvOp o = fromList [(30, IDTrunc), (31, IDZExt), (32, IDSExt), (33, IDFPtoUI),- (34, IDFPtoSI), (35, IDUItoFP), (36, IDSItoFP), (37, IDFPTrunc),- (38, IDFPExt), (39, IDPtrToInt), (40, IDIntToPtr), (41, IDBitcast)] ! o- toPairs xs = zip (stride 2 xs) (stride 2 (drop 1 xs))+ where toPairs xs = zip (stride 2 xs) (stride 2 (drop 1 xs)) stride _ [] = [] stride n (x:xs) = x : stride n (drop (n-1) xs) getPtrType (TDPtr t) = t@@ -236,6 +236,22 @@ getImmInt (AI i) = i getImmInt _ = 0 +binOpMap :: Map CInt BinOpDesc+binOpMap =+ Map.fromList+ [(8, BOAdd), (9, BOFAdd), (10, BOSub), (11, BOFSub),+ (12, BOMul), (13, BOFMul), (14, BOUDiv), (15, BOSDiv),+ (16, BOFDiv), (17, BOURem), (18, BOSRem), (19, BOFRem),+ (20, BOShL), (21, BOLShR), (22, BOAShR), (23, BOAnd),+ (24, BOOr), (25, BOXor)]++convOpMap :: Map CInt (TypeDesc -> TypeDesc -> ArgDesc -> InstrDesc)+convOpMap =+ Map.fromList+ [(30, IDTrunc), (31, IDZExt), (32, IDSExt), (33, IDFPtoUI),+ (34, IDFPtoSI), (35, IDUItoFP), (36, IDSItoFP), (37, IDFPTrunc),+ (38, IDFPExt), (39, IDPtrToInt), (40, IDIntToPtr), (41, IDBitcast)]+ -- TODO: fix for non-int constants getArgDesc :: (String, FFI.ValueRef) -> IO ArgDesc getArgDesc (vname, v) = do@@ -767,23 +783,23 @@ (cmpBld (LP.Proxy :: LP.Proxy a) p) ucmpBld :: CmpPredicate -> FFIBinOp-ucmpBld p = flip FFI.buildICmp (fromIntPredicate (uintFromCmpPredicate p))+ucmpBld p = flip FFI.buildICmp (FFI.fromIntPredicate (uintFromCmpPredicate p)) scmpBld :: CmpPredicate -> FFIBinOp-scmpBld p = flip FFI.buildICmp (fromIntPredicate (sintFromCmpPredicate p))+scmpBld p = flip FFI.buildICmp (FFI.fromIntPredicate (sintFromCmpPredicate p)) fcmpBld :: CmpPredicate -> FFIBinOp-fcmpBld p = flip FFI.buildFCmp (fromFPPredicate (fpFromCmpPredicate p))+fcmpBld p = flip FFI.buildFCmp (FFI.fromRealPredicate (fpFromCmpPredicate p)) ucmpCnst :: CmpPredicate -> FFIConstBinOp-ucmpCnst p = FFI.constICmp (fromIntPredicate (uintFromCmpPredicate p))+ucmpCnst p = FFI.constICmp (FFI.fromIntPredicate (uintFromCmpPredicate p)) scmpCnst :: CmpPredicate -> FFIConstBinOp-scmpCnst p = FFI.constICmp (fromIntPredicate (sintFromCmpPredicate p))+scmpCnst p = FFI.constICmp (FFI.fromIntPredicate (sintFromCmpPredicate p)) fcmpCnst :: CmpPredicate -> FFIConstBinOp-fcmpCnst p = FFI.constFCmp (fromFPPredicate (fpFromCmpPredicate p))+fcmpCnst p = FFI.constFCmp (FFI.fromRealPredicate (fpFromCmpPredicate p)) _ucmp ::@@ -804,8 +820,8 @@ CodeGenFunction r (BinOpValue value0 value1 (Ptr a)) pcmp p = binop- (FFI.constICmp (fromIntPredicate p))- (flip FFI.buildICmp (fromIntPredicate p))+ (FFI.constICmp (FFI.fromIntPredicate p))+ (flip FFI.buildICmp (FFI.fromIntPredicate p)) {-# DEPRECATED icmp "use cmp or pcmp instead" #-}@@ -816,8 +832,8 @@ CodeGenFunction r (CmpValueResult value0 value1 a) icmp p = binop- (FFI.constICmp (fromIntPredicate p))- (flip FFI.buildICmp (fromIntPredicate p))+ (FFI.constICmp (FFI.fromIntPredicate p))+ (flip FFI.buildICmp (FFI.fromIntPredicate p)) -- | Compare floating point values. fcmp ::@@ -826,8 +842,8 @@ CodeGenFunction r (CmpValueResult value0 value1 a) fcmp p = binop- (FFI.constFCmp (fromFPPredicate p))- (flip FFI.buildFCmp (fromFPPredicate p))+ (FFI.constFCmp (FFI.fromRealPredicate p))+ (flip FFI.buildFCmp (FFI.fromRealPredicate p)) -------------------------------------- @@ -1205,25 +1221,25 @@ {- instance (IsConst a) => Eq (ConstValue a) where ConstValue x == ConstValue y =- if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOEQ) x y)- else ConstValue (FFI.constICmp (fromIntPredicate IntEQ) x y)+ if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate FPOEQ) x y)+ else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntEQ) x y) ConstValue x /= ConstValue y =- if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPONE) x y)- else ConstValue (FFI.constICmp (fromIntPredicate IntNE) x y)+ if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate FPONE) x y)+ else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntNE) x y) instance (IsConst a) => Ord (ConstValue a) where ConstValue x < ConstValue y =- if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOLT) x y)- else ConstValue (FFI.constICmp (fromIntPredicate IntLT) x y)+ if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate FPOLT) x y)+ else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntLT) x y) ConstValue x <= ConstValue y =- if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOLE) x y)- else ConstValue (FFI.constICmp (fromIntPredicate IntLE) x y)+ if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate FPOLE) x y)+ else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntLE) x y) ConstValue x > ConstValue y =- if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOGT) x y)- else ConstValue (FFI.constICmp (fromIntPredicate IntGT) x y)+ if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate FPOGT) x y)+ else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntGT) x y) ConstValue x >= ConstValue y =- if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOGE) x y)- else ConstValue (FFI.constICmp (fromIntPredicate IntGE) x y)+ if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate FPOGE) x y)+ else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntGE) x y) -} instance (Num a, IsConst a) => Num (ConstValue a) where
src/LLVM/Core/Instructions/Guided.hs view
@@ -293,10 +293,10 @@ in if isFloating (proxyFromGuide guide) then cmpop FFI.constFCmp FFI.buildFCmp $- Priv.fromFPPredicate $ Priv.fpFromCmpPredicate p+ FFI.fromRealPredicate $ Priv.fpFromCmpPredicate p else cmpop FFI.constICmp FFI.buildICmp $- Priv.fromIntPredicate $+ FFI.fromIntPredicate $ if isSigned guide then Priv.sintFromCmpPredicate p else Priv.uintFromCmpPredicate p@@ -309,13 +309,13 @@ _cmp guide@Guide p = if isFloating (proxyFromGuide guide) then- let predi = Priv.fromFPPredicate $ Priv.fpFromCmpPredicate p+ let predi = FFI.fromRealPredicate $ Priv.fpFromCmpPredicate p in Priv.binop (FFI.constFCmp predi) (flip FFI.buildFCmp predi) else let predi =- Priv.fromIntPredicate $+ FFI.fromIntPredicate $ if isSigned guide then Priv.sintFromCmpPredicate p else Priv.uintFromCmpPredicate p@@ -329,28 +329,28 @@ (ValueCons value, IsIntegerOrPointer a, IsPrimitive a, Type shape a ~ av, Type shape Bool ~ bv) => Guide shape a ->- Priv.IntPredicate -> value av -> value av -> CodeGenFunction r (value bv)+ FFI.IntPredicate -> value av -> value av -> CodeGenFunction r (value bv) icmp Guide p = Priv.binop- (FFI.constICmp (Priv.fromIntPredicate p))- (flip FFI.buildICmp (Priv.fromIntPredicate p))+ (FFI.constICmp (FFI.fromIntPredicate p))+ (flip FFI.buildICmp (FFI.fromIntPredicate p)) -- | Compare pointers. pcmp :: (ValueCons value, Type shape (Ptr a) ~ av, Type shape Bool ~ bv) => Guide shape (Ptr a) ->- Priv.IntPredicate -> value av -> value av -> CodeGenFunction r (value bv)+ FFI.IntPredicate -> value av -> value av -> CodeGenFunction r (value bv) pcmp Guide p = Priv.binop- (FFI.constICmp (Priv.fromIntPredicate p))- (flip FFI.buildICmp (Priv.fromIntPredicate p))+ (FFI.constICmp (FFI.fromIntPredicate p))+ (flip FFI.buildICmp (FFI.fromIntPredicate p)) -- | Compare floating point values. fcmp :: (ValueCons value, IsFloating a, IsPrimitive a, Type shape a ~ av, Type shape Bool ~ bv) => Guide shape a ->- Priv.FPPredicate -> value av -> value av -> CodeGenFunction r (value bv)+ FFI.FPPredicate -> value av -> value av -> CodeGenFunction r (value bv) fcmp Guide p = Priv.binop- (FFI.constFCmp (Priv.fromFPPredicate p))- (flip FFI.buildFCmp (Priv.fromFPPredicate p))+ (FFI.constFCmp (FFI.fromRealPredicate p))+ (flip FFI.buildFCmp (FFI.fromRealPredicate p))
src/LLVM/Core/Instructions/Private.hs view
@@ -16,13 +16,12 @@ (ConstValue(ConstValue), constOf, Value(Value), withCurrentBuilder) import qualified LLVM.FFI.Core as FFI+import LLVM.FFI.Core (IntPredicate(..), FPPredicate(..)) import qualified Type.Data.Num.Decimal.Number as Dec import Type.Data.Num.Decimal.Number (Pred) import Type.Base.Proxy (Proxy) -import Foreign.C (CInt)- import Control.Monad.IO.Class (liftIO) import Control.Monad (liftM) @@ -290,48 +289,3 @@ CmpGE -> FPOGE CmpLT -> FPOLT CmpLE -> FPOLE---data IntPredicate =- IntEQ -- ^ equal- | IntNE -- ^ not equal- | IntUGT -- ^ unsigned greater than- | IntUGE -- ^ unsigned greater or equal- | IntULT -- ^ unsigned less than- | IntULE -- ^ unsigned less or equal- | IntSGT -- ^ signed greater than- | IntSGE -- ^ signed greater or equal- | IntSLT -- ^ signed less than- | IntSLE -- ^ signed less or equal- deriving (Eq, Ord, Enum, Show, Typeable)--fromIntPredicate :: IntPredicate -> CInt-fromIntPredicate p = fromIntegral (fromEnum p + 32)--toIntPredicate :: CInt -> IntPredicate-toIntPredicate p = toEnum $ fromIntegral p - 32--data FPPredicate =- FPFalse -- ^ Always false (always folded)- | FPOEQ -- ^ True if ordered and equal- | FPOGT -- ^ True if ordered and greater than- | FPOGE -- ^ True if ordered and greater than or equal- | FPOLT -- ^ True if ordered and less than- | FPOLE -- ^ True if ordered and less than or equal- | FPONE -- ^ True if ordered and operands are unequal- | FPORD -- ^ True if ordered (no nans)- | FPUNO -- ^ True if unordered: isnan(X) | isnan(Y)- | FPUEQ -- ^ True if unordered or equal- | FPUGT -- ^ True if unordered or greater than- | FPUGE -- ^ True if unordered, greater than, or equal- | FPULT -- ^ True if unordered or less than- | FPULE -- ^ True if unordered, less than, or equal- | FPUNE -- ^ True if unordered or not equal- | FPTrue -- ^ Always true (always folded)- deriving (Eq, Ord, Enum, Show, Typeable)--fromFPPredicate :: FPPredicate -> CInt-fromFPPredicate p = fromIntegral (fromEnum p)--toFPPredicate :: CInt -> FPPredicate-toFPPredicate p = toEnum $ fromIntegral p
src/LLVM/Core/Type.hs view
@@ -35,6 +35,8 @@ StructFields, UnknownSize, -- needed for arrays of structs -- ** Structs+ CurryStruct(..), consStruct,+ UncurryStruct(uncurryStruct), Curried, (:&), (&), -- ** Type tests TypeDesc(..),@@ -87,18 +89,18 @@ typeRef :: (IsType a) => Proxy a -> IO FFI.TypeRef typeRef = code . typeDesc where code TDFloat = FFI.floatType- code TDDouble = FFI.doubleType- code TDFP128 = FFI.fp128Type- code TDVoid = FFI.voidType- code (TDInt _ n) = FFI.integerType (fromInteger n)- code (TDArray n a) = withCode FFI.arrayType (code a) (fromInteger n)- code (TDVector n a) = withCode FFI.vectorType (code a) (fromInteger n)- code (TDPtr a) = withCode FFI.pointerType (code a) 0- code (TDFunction va as b) = do+ code TDDouble = FFI.doubleType+ code TDFP128 = FFI.fp128Type+ code TDVoid = FFI.voidType+ code (TDInt _ n) = FFI.integerType (fromInteger n)+ code (TDArray n a) = withCode FFI.arrayType (code a) (fromInteger n)+ code (TDVector n a) = withCode FFI.vectorType (code a) (fromInteger n)+ code (TDPtr a) = withCode FFI.pointerType (code a) 0+ code (TDFunction va as b) = do bt <- code b ast <- mapM code as functionType va bt ast- code TDLabel = FFI.labelType+ code TDLabel = FFI.labelType code (TDStruct ts packed) = withCode structType (mapM code ts) packed code TDInvalidType = error "typeRef TDInvalidType" @@ -117,14 +119,14 @@ typeName :: (IsType a) => Proxy a -> String typeName = code . typeDesc where code TDFloat = "f32"- code TDDouble = "f64"- code TDFP128 = "f128"- code TDVoid = "void"- code (TDInt _ n) = "i" ++ show n- code (TDArray n a) = "[" ++ show n ++ " x " ++ code a ++ "]"- code (TDVector n a) = "<" ++ show n ++ " x " ++ code a ++ ">"- code (TDPtr a) = code a ++ "*"- code (TDFunction _ as b) = code b ++ "(" ++ intercalate "," (map code as) ++ ")"+ code TDDouble = "f64"+ code TDFP128 = "f128"+ code TDVoid = "void"+ code (TDInt _ n) = "i" ++ show n+ code (TDArray n a) = "[" ++ show n ++ " x " ++ code a ++ "]"+ code (TDVector n a) = "<" ++ show n ++ " x " ++ code a ++ ">"+ code (TDPtr a) = code a ++ "*"+ code (TDFunction _ as b) = code b ++ "(" ++ intercalate "," (map code as) ++ ")" code TDLabel = "label" code (TDStruct as packed) = (if packed then "<{" else "{") ++ intercalate "," (map code as) ++@@ -178,7 +180,7 @@ -- |Type descriptor, used to convey type information through the LLVM API. data TypeDesc = TDFloat | TDDouble | TDFP128 | TDVoid | TDInt Bool Integer | TDArray Integer TypeDesc | TDVector Integer TypeDesc- | TDPtr TypeDesc | TDFunction Bool [TypeDesc] TypeDesc | TDLabel+ | TDPtr TypeDesc | TDFunction Bool [TypeDesc] TypeDesc | TDLabel | TDStruct [TypeDesc] Bool | TDInvalidType deriving (Eq, Ord, Show, Typeable) @@ -220,11 +222,11 @@ isSigned :: (IsArithmetic a) => Proxy a -> Bool isSigned = is . typeDesc where is (TDInt s _) = s- is (TDVector _ a) = is a- is TDFloat = True- is TDDouble = True- is TDFP128 = True- is _ = error "isSigned got impossible input"+ is (TDVector _ a) = is a+ is TDFloat = True+ is TDDouble = True+ is TDFP128 = True+ is _ = error "isSigned got impossible input" -- Usage: -- constF@@ -235,10 +237,10 @@ isFloating :: (IsArithmetic a) => Proxy a -> Bool isFloating = is . typeDesc where is TDFloat = True- is TDDouble = True- is TDFP128 = True- is (TDVector _ a) = is a- is _ = False+ is TDDouble = True+ is TDFP128 = True+ is (TDVector _ a) = is a+ is _ = False -- Usage: -- Precondition for Vector@@ -332,12 +334,12 @@ where typeDesc _ = TDArray (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n))- (typeDesc (Proxy :: Proxy a))+ (typeDesc (Proxy :: Proxy a)) instance (Dec.Positive n, IsPrimitive a) => IsType (Vector n a) where typeDesc _ = TDVector (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n))- (typeDesc (Proxy :: Proxy a))+ (typeDesc (Proxy :: Proxy a)) -- Pointer type. instance (IsType a) => IsType (Ptr a) where@@ -379,12 +381,49 @@ instance StructFields () where fieldTypes Proxy = [] ++-- Simplifies construction, pattern matching and conversion to and from records+class CurryStruct f where+ type UncurriedArgument f+ type UncurriedResult f+ curryStruct :: (Struct (UncurriedArgument f) -> UncurriedResult f) -> f++instance CurryStruct (Struct a) where+ type UncurriedArgument (Struct a) = ()+ type UncurriedResult (Struct a) = Struct a+ curryStruct g = g $ Struct ()++instance (CurryStruct f) => CurryStruct (a->f) where+ type UncurriedArgument (a->f) = (a, UncurriedArgument f)+ type UncurriedResult (a->f) = UncurriedResult f+ curryStruct g a = curryStruct (\(Struct r) -> g $ Struct (a,r))++consStruct ::+ (CurryStruct f, UncurriedResult f ~ Struct (UncurriedArgument f)) => f+consStruct = curryStruct id++class UncurryStruct a where+ type Curried a b+ curryStruct' :: (Struct a -> b) -> Curried a b+ uncurryStruct :: Curried a b -> Struct a -> b++instance UncurryStruct () where+ type Curried () b = b+ curryStruct' f = f $ Struct ()+ uncurryStruct f (Struct ()) = f++instance (UncurryStruct r) => UncurryStruct (a,r) where+ type Curried (a,r) b = a -> Curried r b+ curryStruct' f a = curryStruct' (\(Struct r) -> f $ Struct (a,r))+ uncurryStruct f (Struct (a,r)) = uncurryStruct (f a) $ Struct r+ -- An alias for pairs to make structs look nicer infixr :& type (:&) a as = (a, as) infixr & (&) :: a -> as -> a :& as a & as = (a, as)+ --- Instances to classify types instance IsArithmetic Float where arithmeticType = FloatingType
src/LLVM/Core/Util.hs view
@@ -121,7 +121,7 @@ else do buf <- peek bufPtr prc <- FFI.parseBitcode buf modPtr errStr- if FFI.deconsBool prc then do+ if FFI.deconsBool prc then do msg <- peek errStr >>= peekCString ioError $ userError $ "readBitcodeFromFile: parse return code " ++ show prc ++ ", " ++ msg else do@@ -161,27 +161,27 @@ pk <- FFI.getTypeKind p case pk of FFI.VoidTypeKind -> return "()"- FFI.FloatTypeKind -> return "Float"- FFI.DoubleTypeKind -> return "Double"- FFI.X86_FP80TypeKind -> return "X86_FP80"- FFI.FP128TypeKind -> return "FP128"- FFI.PPC_FP128TypeKind -> return "PPC_FP128"- FFI.LabelTypeKind -> return "Label"- FFI.IntegerTypeKind -> do w <- FFI.getIntTypeWidth p; return $ "(IntN " ++ show w ++ ")"- FFI.FunctionTypeKind -> do+ FFI.FloatTypeKind -> return "Float"+ FFI.DoubleTypeKind -> return "Double"+ FFI.X86_FP80TypeKind -> return "X86_FP80"+ FFI.FP128TypeKind -> return "FP128"+ FFI.PPC_FP128TypeKind -> return "PPC_FP128"+ FFI.LabelTypeKind -> return "Label"+ FFI.IntegerTypeKind -> do w <- FFI.getIntTypeWidth p; return $ "(IntN " ++ show w ++ ")"+ FFI.FunctionTypeKind -> do r <- FFI.getReturnType p- c <- FFI.countParamTypes p- let n = fromIntegral c- as <- allocaArray n $ \ args -> do- FFI.getParamTypes p args- peekArray n args- ts <- mapM showType' (as ++ [r])- return $ "(" ++ intercalate " -> " ts ++ ")"- FFI.StructTypeKind -> return "(Struct ...)"- FFI.ArrayTypeKind -> do n <- FFI.getArrayLength p; t <- FFI.getElementType p >>= showType'; return $ "(Array " ++ show n ++ " " ++ t ++ ")"- FFI.PointerTypeKind -> do t <- FFI.getElementType p >>= showType'; return $ "(Ptr " ++ t ++ ")"- FFI.OpaqueTypeKind -> return "Opaque"- FFI.VectorTypeKind -> do n <- FFI.getVectorSize p; t <- FFI.getElementType p >>= showType'; return $ "(Vector " ++ show n ++ " " ++ t ++ ")"+ c <- FFI.countParamTypes p+ let n = fromIntegral c+ as <- allocaArray n $ \ args -> do+ FFI.getParamTypes p args+ peekArray n args+ ts <- mapM showType' (as ++ [r])+ return $ "(" ++ intercalate " -> " ts ++ ")"+ FFI.StructTypeKind -> return "(Struct ...)"+ FFI.ArrayTypeKind -> do n <- FFI.getArrayLength p; t <- FFI.getElementType p >>= showType'; return $ "(Array " ++ show n ++ " " ++ t ++ ")"+ FFI.PointerTypeKind -> do t <- FFI.getElementType p >>= showType'; return $ "(Ptr " ++ t ++ ")"+ FFI.OpaqueTypeKind -> return "Opaque"+ FFI.VectorTypeKind -> do n <- FFI.getVectorSize p; t <- FFI.getElementType p >>= showType'; return $ "(Vector " ++ show n ++ " " ++ t ++ ")" -------------------------------------- -- Handle instruction builders
src/LLVM/ExecutionEngine.hs view
@@ -23,9 +23,17 @@ simpleFunction, unsafeGenerateFunction, -- * Target information- module LLVM.ExecutionEngine.Target+ module LLVM.ExecutionEngine.Target,+ -- * Exchange data with JIT code in memory+ Marshal.Marshal(..),+ Marshal.sizeOf,+ Marshal.alignment,+ Marshal.StructFields,+ Marshal.sizeOfArray,+ Marshal.pokeList, ) where +import qualified LLVM.ExecutionEngine.Marshal as Marshal import LLVM.ExecutionEngine.Engine import LLVM.ExecutionEngine.Target import LLVM.Core.CodeGen (Value(..))
+ src/LLVM/ExecutionEngine/Marshal.hs view
@@ -0,0 +1,186 @@+{- |+A 'Marshal' class that is compatible with LLVM's data layout.+Most prominent difference is that LLVM's @i1@ requires a byte in memory,+whereas Haskell's 'Bool' occupies a 32-bit word.+Additionally this class supports 'Data.Struct', 'Data.Vector', 'Data.Array'.+-}+module LLVM.ExecutionEngine.Marshal (+ Marshal(..),+ sizeOf,+ alignment,+ StructFields,+ sizeOfArray,+ pokeList,+ ) where++import qualified LLVM.Core.Vector as Vector ()+import qualified LLVM.Core.Data as Data+import qualified LLVM.Core.Type as Type+import qualified LLVM.Util.Proxy as LP+import qualified LLVM.ExecutionEngine.Target as Target+import LLVM.ExecutionEngine.Target (TargetData)++import qualified LLVM.FFI.Core as FFI++import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Base.Proxy (Proxy(Proxy))++import qualified Foreign.Storable as Store+import Foreign.StablePtr (StablePtr)+import Foreign.Ptr (Ptr, FunPtr, castPtr, plusPtr)++import System.IO.Unsafe (unsafePerformIO)++import qualified Control.Monad.Trans.State as MS+import Control.Applicative (liftA2, pure)++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64)++++targetData :: TargetData+targetData = unsafePerformIO Target.getTargetData+++sizeOf :: (Type.IsType a) => LP.Proxy a -> Int+sizeOf = Target.storeSizeOfType targetData . Type.unsafeTypeRef++alignment :: (Type.IsType a) => LP.Proxy a -> Int+alignment = Target.abiAlignmentOfType targetData . Type.unsafeTypeRef++sizeOfArray :: (Type.IsType a) => LP.Proxy a -> Int -> Int+sizeOfArray proxy n =+ Target.abiSizeOfType targetData (Type.unsafeTypeRef proxy) * n+++class (Type.IsType a) => Marshal a where+ peek :: Ptr a -> IO a+ poke :: Ptr a -> a -> IO ()++peekPrimitive :: (Store.Storable a) => Ptr a -> IO a+peekPrimitive = Store.peek++pokePrimitive :: (Store.Storable a) => Ptr a -> a -> IO ()+pokePrimitive = Store.poke++instance Marshal Float where+ peek = peekPrimitive; poke = pokePrimitive+instance Marshal Double where+ peek = peekPrimitive; poke = pokePrimitive++instance Marshal Int8 where+ peek = peekPrimitive; poke = pokePrimitive+instance Marshal Int16 where+ peek = peekPrimitive; poke = pokePrimitive+instance Marshal Int32 where+ peek = peekPrimitive; poke = pokePrimitive+instance Marshal Int64 where+ peek = peekPrimitive; poke = pokePrimitive+instance Marshal Word8 where+ peek = peekPrimitive; poke = pokePrimitive+instance Marshal Word16 where+ peek = peekPrimitive; poke = pokePrimitive+instance Marshal Word32 where+ peek = peekPrimitive; poke = pokePrimitive+instance Marshal Word64 where+ peek = peekPrimitive; poke = pokePrimitive+instance (Type.IsType a) => Marshal (Ptr a) where+ peek = peekPrimitive; poke = pokePrimitive+instance (Type.IsFunction a) => Marshal (FunPtr a) where+ peek = peekPrimitive; poke = pokePrimitive+instance Marshal (StablePtr a) where+ peek = peekPrimitive; poke = pokePrimitive++instance Marshal Bool where+ peek = fmap (/= 0) . Store.peek . castBoolPtr+ poke ptr a = Store.poke (castBoolPtr ptr) (fromIntegral $ fromEnum a)++castBoolPtr :: Ptr Bool -> Ptr Word8+castBoolPtr = castPtr++instance+ (Type.Natural n, Marshal a, Type.IsSized a) =>+ Marshal (Data.Array n a) where+ peek = peekArray Proxy LP.Proxy+ poke = pokeArray (\(Data.Array as) -> as)++instance+ (Type.Positive n, Marshal a, Type.IsPrimitive a) =>+ Marshal (Data.Vector n a) where+ peek = peekVector Proxy LP.Proxy+ poke = pokeArray Fold.toList++peekArray ::+ (Type.Natural n, Marshal a) =>+ Proxy n -> LP.Proxy a ->+ Ptr (Data.Array n a) -> IO (Data.Array n a)+peekArray n proxy =+ let step = Target.abiSizeOfType targetData $ Type.unsafeTypeRef proxy+ in \ptr ->+ fmap Data.Array $ mapM peek $+ take (Dec.integralFromProxy n) $+ iterate (flip plusPtr step) (castElemPtr ptr)++peekVector ::+ (Type.Positive n, Marshal a) =>+ Proxy n -> LP.Proxy a ->+ Ptr (Data.Vector n a) -> IO (Data.Vector n a)+peekVector _n proxy =+ let step = Target.abiSizeOfType targetData $ Type.unsafeTypeRef proxy+ in \ptr ->+ flip MS.evalStateT (castElemPtr ptr) $+ Trav.traverse+ (\() -> MS.StateT $ \ptri -> do+ a <- peek ptri+ return (a, plusPtr ptri step))+ (pure ())++pokeArray :: (Marshal a) => (f a -> [a]) -> Ptr (f a) -> f a -> IO ()+pokeArray toList ptr = pokeList (castElemPtr ptr) . toList++pokeList :: (Marshal a) => Ptr a -> [a] -> IO ()+pokeList = pokeListAux LP.Proxy++pokeListAux :: (Marshal a) => LP.Proxy a -> Ptr a -> [a] -> IO ()+pokeListAux proxy =+ let step = Target.abiSizeOfType targetData $ Type.unsafeTypeRef proxy+ in \ptr -> sequence_ . zipWith poke (iterate (flip plusPtr step) ptr)++castElemPtr :: Ptr (f a) -> Ptr a+castElemPtr = castPtr+++instance (StructFields fields) => Marshal (Data.Struct fields) where+ peek = withPtrProxy $ \proxy ->+ let typeRef = Type.unsafeTypeRef proxy+ in fmap Data.Struct . peekStruct typeRef 0+ poke = withPtrProxy $ \proxy ->+ let typeRef = Type.unsafeTypeRef proxy+ pokePlain = pokeStruct typeRef 0+ in \ptr (Data.Struct as) -> pokePlain ptr as++withPtrProxy :: (LP.Proxy a -> Ptr a -> b) -> Ptr a -> b+withPtrProxy act = act LP.Proxy++class (Type.StructFields fields) => StructFields fields where+ peekStruct :: FFI.TypeRef -> Int -> Ptr struct -> IO fields+ pokeStruct :: FFI.TypeRef -> Int -> Ptr struct -> fields -> IO ()++instance+ (Marshal a, Type.IsSized a, StructFields as) =>+ StructFields (a,as) where+ peekStruct typeRef i =+ let offset = Target.offsetOfElement targetData typeRef i+ peekIs = peekStruct typeRef (i+1)+ in \ptr -> liftA2 (,) (peek $ plusPtr ptr offset) (peekIs ptr)+ pokeStruct typeRef i =+ let offset = Target.offsetOfElement targetData typeRef i+ pokeIs = pokeStruct typeRef (i+1)+ in \ptr (a,as) -> poke (plusPtr ptr offset) a >> pokeIs ptr as++instance StructFields () where+ peekStruct _type _i _ptr = return ()+ pokeStruct _type _i _ptr () = return ()
src/LLVM/ExecutionEngine/Target.hs view
@@ -31,7 +31,7 @@ callFrameAlignmentOfType :: Type -> Int, -- elementAtOffset :: Type -> Word64 -> Int, intPtrType :: Type,--- offsetOfElements :: Int -> Word64,+ offsetOfElement :: Type -> Int -> Int, pointerSize :: Int, -- preferredAlignmentOfGlobal :: Value a -> Int, preferredAlignmentOfType :: Type -> Int,@@ -65,6 +65,8 @@ littleEndian = unsafeIO fptr (FFI.byteOrder r) /= FFI.bigEndian, callFrameAlignmentOfType = unsafeIntIO fptr . FFI.callFrameAlignmentOfType r, intPtrType = unsafeIO fptr $ FFI.intPtrType r,+ offsetOfElement = \ty k ->+ unsafeIntIO fptr $ FFI.offsetOfElement r ty (fromIntegral k), pointerSize = unsafeIntIO fptr $ FFI.pointerSize r, preferredAlignmentOfType = unsafeIntIO fptr . FFI.preferredAlignmentOfType r, sizeOfTypeInBits = unsafeIntIO fptr . FFI.sizeOfTypeInBits r,
src/LLVM/Util/Arithmetic.hs view
@@ -86,8 +86,10 @@ set :: TValue r a -> CodeGenFunction r (TValue r a) set x = do x' <- x; return (return x') -instance Eq (TValue r a)-instance Ord (TValue r a)+instance Eq (TValue r a) where+ (==) = error "CodeGenFunction Value: (==)"+instance Ord (TValue r a) where+ compare = error "CodeGenFunction Value: compare" instance (IsArithmetic a, CmpRet a, Num a, IsConst a) => Num (TValue r a) where (+) = binop add