diff --git a/example/Arith.hs b/example/Arith.hs --- a/example/Arith.hs +++ b/example/Arith.hs @@ -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 = diff --git a/example/Array.hs b/example/Array.hs --- a/example/Array.hs +++ b/example/Array.hs @@ -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 diff --git a/example/BrainF.hs b/example/BrainF.hs --- a/example/BrainF.hs +++ b/example/BrainF.hs @@ -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, ()) diff --git a/llvm-tf.cabal b/llvm-tf.cabal --- a/llvm-tf.cabal +++ b/llvm-tf.cabal @@ -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) diff --git a/src/LLVM/Core/CodeGen.hs b/src/LLVM/Core/CodeGen.hs --- a/src/LLVM/Core/CodeGen.hs +++ b/src/LLVM/Core/CodeGen.hs @@ -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 -------------------------------------- diff --git a/src/LLVM/Core/CodeGenMonad.hs b/src/LLVM/Core/CodeGenMonad.hs --- a/src/LLVM/Core/CodeGenMonad.hs +++ b/src/LLVM/Core/CodeGenMonad.hs @@ -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 diff --git a/src/LLVM/Core/Instructions.hs b/src/LLVM/Core/Instructions.hs --- a/src/LLVM/Core/Instructions.hs +++ b/src/LLVM/Core/Instructions.hs @@ -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 diff --git a/src/LLVM/Core/Instructions/Guided.hs b/src/LLVM/Core/Instructions/Guided.hs --- a/src/LLVM/Core/Instructions/Guided.hs +++ b/src/LLVM/Core/Instructions/Guided.hs @@ -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)) diff --git a/src/LLVM/Core/Instructions/Private.hs b/src/LLVM/Core/Instructions/Private.hs --- a/src/LLVM/Core/Instructions/Private.hs +++ b/src/LLVM/Core/Instructions/Private.hs @@ -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 diff --git a/src/LLVM/Core/Type.hs b/src/LLVM/Core/Type.hs --- a/src/LLVM/Core/Type.hs +++ b/src/LLVM/Core/Type.hs @@ -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 diff --git a/src/LLVM/Core/Util.hs b/src/LLVM/Core/Util.hs --- a/src/LLVM/Core/Util.hs +++ b/src/LLVM/Core/Util.hs @@ -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 diff --git a/src/LLVM/ExecutionEngine.hs b/src/LLVM/ExecutionEngine.hs --- a/src/LLVM/ExecutionEngine.hs +++ b/src/LLVM/ExecutionEngine.hs @@ -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(..)) diff --git a/src/LLVM/ExecutionEngine/Marshal.hs b/src/LLVM/ExecutionEngine/Marshal.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/ExecutionEngine/Marshal.hs @@ -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 () diff --git a/src/LLVM/ExecutionEngine/Target.hs b/src/LLVM/ExecutionEngine/Target.hs --- a/src/LLVM/ExecutionEngine/Target.hs +++ b/src/LLVM/ExecutionEngine/Target.hs @@ -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, diff --git a/src/LLVM/Util/Arithmetic.hs b/src/LLVM/Util/Arithmetic.hs --- a/src/LLVM/Util/Arithmetic.hs +++ b/src/LLVM/Util/Arithmetic.hs @@ -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