diff --git a/example/Convert.hs b/example/Convert.hs --- a/example/Convert.hs +++ b/example/Convert.hs @@ -19,7 +19,7 @@ foreign import ccall safe "dynamic" c_Float_Float :: Importer (Float -> Float) instance Convert (Float -> Float) where convert = c_Float_Float - + foreign import ccall safe "dynamic" c_IODouble :: Importer (IO Double) instance Convert (IO Double) where convert = c_IODouble @@ -28,7 +28,7 @@ foreign import ccall safe "dynamic" c_Double_Double :: Importer (Double -> Double) instance Convert (Double -> Double) where convert = c_Double_Double - + foreign import ccall safe "dynamic" c_Word32_IOWord32 :: Importer (Word32 -> IO Word32) instance Convert (Word32 -> IO Word32) where convert = c_Word32_IOWord32 diff --git a/example/Intrinsic.hs b/example/Intrinsic.hs --- a/example/Intrinsic.hs +++ b/example/Intrinsic.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ForeignFunctionInterface #-} module Main where import qualified LLVM.Core as LLVM @@ -6,7 +7,7 @@ import qualified Foreign.Marshal.Utils as MU import Foreign.Marshal.Alloc (alloca, ) import Foreign.Storable (Storable, peek, ) -import Foreign.Ptr (Ptr, ) +import Foreign.Ptr (Ptr, FunPtr, ) import qualified Type.Data.Num.Decimal as TypeNum import qualified Data.Word as W @@ -47,17 +48,23 @@ flip LLVM.store ptr1 =<< flip roundps (LLVM.valueOf 1) =<< LLVM.load ptr0 LLVM.ret () +type Importer func = FunPtr func -> func + +foreign import ccall safe "dynamic" derefFloorPtr :: + Importer (Ptr Vector -> Ptr Vector -> IO ()) + run :: IO () run = do m <- LLVM.newModule - _f <- LLVM.defineModule m $ LLVM.setTarget LLVM.hostTriple >> modul + floorFunc <- do + func <- LLVM.defineModule m $ LLVM.setTarget LLVM.hostTriple >> modul + EE.runEngineAccessWithModule m $ EE.getPointerToFunction func LLVM.writeBitcodeToFile "floor.bc" m print vector - floorFunc <- EE.simpleFunction modul MU.with vector $ \ptr0 -> alloca $ \ptr1 -> do - floorFunc ptr0 ptr1 + derefFloorPtr floorFunc ptr0 ptr1 print =<< peek ptr1 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: 3.0.3.2 +Version: 3.0.3.3 License: BSD3 License-File: LICENSE Synopsis: Bindings to the LLVM compiler toolkit using type families. @@ -37,7 +37,7 @@ Location: http://code.haskell.org/~thielema/llvm-tf/ Source-Repository this - Tag: 3.0.3.2 + Tag: 3.0.3.3 Type: darcs Location: http://code.haskell.org/~thielema/llvm-tf/ @@ -53,11 +53,12 @@ Library Default-Language: Haskell98 Build-Depends: - llvm-ffi >= 3.5.1 && <3.6, + llvm-ffi >= 3.6 && <3.7, tfp >=1.0 && <1.1, transformers >=0.3 && <0.6, process >=1.1 && <1.5, storable-record >=0.0.2 && <0.1, + enumset >=0.0.4 && <0.1, fixed-length >=0.2 && <0.3, non-empty >=0.2 && <0.4, utility-ht >=0.0.10 && <0.1, diff --git a/src/LLVM/Core.hs b/src/LLVM/Core.hs --- a/src/LLVM/Core.hs +++ b/src/LLVM/Core.hs @@ -59,7 +59,7 @@ TFunction, liftCodeGenModule, getParams, -- * Global variable creation Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal, - externFunction, staticFunction, + externFunction, staticFunction, staticNamedFunction, externGlobal, staticGlobal, GlobalMappings, getGlobalMappings, TGlobal, @@ -67,7 +67,7 @@ Linkage(..), -- * Basic blocks BasicBlock, newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock, - getBasicBlocks, + getBasicBlocks, fromLabel, toLabel, getInstructions, getOperands, hasUsers, getUsers, getUses, getUser, isChildOf, getDep, -- * Misc 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 @@ -15,7 +15,7 @@ Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction, setFuncCallConv, addAttributes, FFI.Attribute(..), - externFunction, staticFunction, + externFunction, staticFunction, staticNamedFunction, FunctionArgs, FunctionCodeGen, FunctionResult, TFunction, -- * Global variable creation @@ -195,14 +195,13 @@ constEnum :: (Enum a) => IO FFI.TypeRef -> a -> ConstValue a constEnum mt i = - unsafeConstValue $ mt >>= \t -> FFI.constInt t (fromIntegral $ fromEnum i) 0 + unsafeConstValue $ mt >>= \t -> + FFI.constInt t (fromIntegral $ fromEnum i) FFI.false constI :: (IsInteger a, Integral a) => a -> ConstValue a constI i = unsafeWithConstValue $ \typ -> - FFI.constInt - typ (fromIntegral i) - (fromIntegral $ fromEnum $ isSigned $ LP.fromValue i) + FFI.constInt typ (fromIntegral i) (FFI.consBool $ isSigned $ LP.fromValue i) constF :: (IsFloating a, Real a) => a -> ConstValue a constF i = @@ -433,8 +432,15 @@ . -} staticFunction :: forall f r. (IsFunction f) => FunPtr f -> CodeGenFunction r (Function f) -staticFunction func = liftCodeGenModule $ do - val <- newNamedFunction ExternalLinkage "" +staticFunction = staticNamedFunction "" + +{- | +Due to +this will fail with MCJIT of LLVM-3.6. +-} +staticNamedFunction :: forall f r. (IsFunction f) => String -> FunPtr f -> CodeGenFunction r (Function f) +staticNamedFunction name func = liftCodeGenModule $ do + val <- newNamedFunction ExternalLinkage name addFunctionMapping (unValue (val :: Function f)) func return val @@ -472,7 +478,7 @@ typ <- liftIO $ typeRef (LP.Proxy :: LP.Proxy a) liftIO $ liftM Value $ do g <- U.addGlobal modul linkage name typ - when isConst $ FFI.setGlobalConstant g 1 + when isConst $ FFI.setGlobalConstant g FFI.true return g -- | Create a new global variable. @@ -542,7 +548,7 @@ 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 1 + 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 @@ -57,7 +57,7 @@ -------------------------------------- -data CGFState r = CGFState { +data CGFState r = CGFState { cgf_module :: CGMState, cgf_builder :: Builder, cgf_function :: Function, 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 @@ -1146,7 +1146,7 @@ arrayMalloc :: forall a r s . (IsSized a, AllocArg s) => s -> CodeGenFunction r (Value (Ptr a)) -- XXX arrayMalloc s = do - func <- staticFunction alignedMalloc + func <- staticNamedFunction "alignedMalloc" alignedMalloc -- func <- externFunction "malloc" size <- sizeOfArray (LP.Proxy :: LP.Proxy a) (getAllocArg s) @@ -1182,7 +1182,7 @@ -- | Free heap memory. free :: (IsType a) => Value (Ptr a) -> CodeGenFunction r () free ptr = do - func <- staticFunction alignedFree + func <- staticNamedFunction "alignedFree" alignedFree -- func <- externFunction "free" _ <- call (func :: Function (Ptr Word8 -> IO ())) =<< bitcast ptr return () 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 @@ -53,7 +53,6 @@ import Foreign.Marshal.Array (withArrayLen, withArray, allocaArray, peekArray) import Foreign.Marshal.Alloc (alloca) import Foreign.Storable (Storable(..)) -import Foreign.Marshal.Utils (fromBool, toBool) import System.IO.Unsafe (unsafePerformIO) import Data.Typeable (Typeable) @@ -66,12 +65,12 @@ functionType :: Bool -> Type -> [Type] -> IO Type functionType varargs retType paramTypes = withArrayLen paramTypes $ \ len ptr -> - FFI.functionType retType ptr (fromIntegral len) (fromBool varargs) + FFI.functionType retType ptr (fromIntegral len) (FFI.consBool varargs) structType :: [Type] -> Bool -> IO Type structType types packed = withArrayLen types $ \ len ptr -> - FFI.structType ptr (fromIntegral len) (fromBool packed) + FFI.structType ptr (fromIntegral len) (FFI.consBool packed) -------------------------------------- -- Handle modules @@ -120,13 +119,13 @@ alloca $ \ modPtr -> alloca $ \ errStr -> do rrc <- FFI.createMemoryBufferWithContentsOfFile namePtr bufPtr errStr - if rrc /= 0 then do + if FFI.deconsBool rrc then do msg <- peek errStr >>= peekCString ioError $ userError $ "readBitcodeFromFile: read return code " ++ show rrc ++ ", " ++ msg else do buf <- peek bufPtr prc <- FFI.parseBitcode buf modPtr errStr - if prc /= 0 then do + if FFI.deconsBool prc then do msg <- peek errStr >>= peekCString ioError $ userError $ "readBitcodeFromFile: parse return code " ++ show prc ++ ", " ++ msg else do @@ -284,7 +283,7 @@ constStringInternal :: Bool -> String -> Value constStringInternal nulTerm s = unsafePerformIO $ withCStringLen s $ \(sPtr, sLen) -> - FFI.constString sPtr (fromIntegral sLen) (fromBool (not nulTerm)) + FFI.constString sPtr (fromIntegral sLen) (FFI.consBool (not nulTerm)) constString :: String -> Value constString = constStringInternal False @@ -413,14 +412,14 @@ addTargetData :: FFI.TargetDataRef -> PassManager -> IO () addTargetData td pm = withPassManager pm $ FFI.addTargetData td -runFunctionPassManager :: PassManager -> Function -> IO Int -runFunctionPassManager pm fcn = liftM fromIntegral $ withPassManager pm $ \ pmref -> FFI.runFunctionPassManager pmref fcn +runFunctionPassManager :: PassManager -> Function -> IO FFI.Bool +runFunctionPassManager pm fcn = withPassManager pm $ \ pmref -> FFI.runFunctionPassManager pmref fcn -initializeFunctionPassManager :: PassManager -> IO Int -initializeFunctionPassManager pm = liftM fromIntegral $ withPassManager pm FFI.initializeFunctionPassManager +initializeFunctionPassManager :: PassManager -> IO FFI.Bool +initializeFunctionPassManager pm = withPassManager pm FFI.initializeFunctionPassManager -finalizeFunctionPassManager :: PassManager -> IO Int -finalizeFunctionPassManager pm = liftM fromIntegral $ withPassManager pm FFI.finalizeFunctionPassManager +finalizeFunctionPassManager :: PassManager -> IO FFI.Bool +finalizeFunctionPassManager pm = withPassManager pm FFI.finalizeFunctionPassManager -------------------------------------- @@ -437,7 +436,7 @@ constStruct :: [Value] -> Bool -> IO Value constStruct xs packed = do withArrayLen xs $ \ len ptr -> - FFI.constStruct ptr (fromIntegral len) (fromBool packed) + FFI.constStruct ptr (fromIntegral len) (FFI.consBool packed) -------------------------------------- @@ -465,17 +464,17 @@ return $ zip names vs isConstant :: Value -> IO Bool -isConstant v = fmap toBool $ FFI.isConstant v +isConstant v = fmap FFI.deconsBool $ FFI.isConstant v isIntrinsic :: Value -> IO Bool -isIntrinsic v = fmap toBool $ FFI.getIntrinsicID v +isIntrinsic v = fmap (/=0) $ FFI.getIntrinsicID v -------------------------------------- type Use = FFI.UseRef hasUsers :: Value -> IO Bool -hasUsers v = fmap toBool $ FFI.getNumUses v +hasUsers v = fmap (>0) $ FFI.getNumUses v getUses :: Value -> IO [Use] getUses = getObjList withValue FFI.getFirstUse FFI.getNextUse diff --git a/src/LLVM/ExecutionEngine.hs b/src/LLVM/ExecutionEngine.hs --- a/src/LLVM/ExecutionEngine.hs +++ b/src/LLVM/ExecutionEngine.hs @@ -28,8 +28,8 @@ import LLVM.ExecutionEngine.Target import LLVM.Core.CodeGen (Value(..)) import LLVM.Core - (CodeGenModule, Function, newModule, defineModule, getGlobalMappings) ---import LLVM.Core.Util(runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager) + (CodeGenModule, Function, newModule, defineModule, getGlobalMappings, + setTarget, hostTriple) import LLVM.FFI.Core (ValueRef) @@ -79,34 +79,12 @@ simpleFunction :: (Translatable f) => CodeGenModule (Function f) -> IO f simpleFunction bld = do m <- newModule - (func, mappings) <- defineModule m (liftM2 (,) bld getGlobalMappings) - runEngineAccessWithModule m $ do + (func, mappings) <- + defineModule m $ + setTarget hostTriple >> liftM2 (,) bld getGlobalMappings + runEngineAccessInterpreterWithModule m $ do addGlobalMappings mappings generateFunction func - -{- - m <- newModule - func <- defineModule m bld --- dumpValue func - prov <- createModuleProviderForExistingModule m - ee <- createExecutionEngine prov - pm <- createFunctionPassManager prov - td <- getExecutionEngineTargetData ee - addTargetData td pm - addInstructionCombiningPass pm - addReassociatePass pm - addGVNPass pm - addCFGSimplificationPass pm - addPromoteMemoryToRegisterPass pm - initializeFunctionPassManager pm --- print ("rc1", rc1) - runFunctionPassManager pm (unValue func) --- print ("rc2", rc2) - finalizeFunctionPassManager pm --- print ("rc3", rc3) --- dumpValue func - return $ generateFunction ee func --} -- | Combine 'simpleFunction' and 'unsafeRemoveIO'. unsafeGenerateFunction :: (Unsafe t, Translatable t) => diff --git a/src/LLVM/ExecutionEngine/Engine.hs b/src/LLVM/ExecutionEngine/Engine.hs --- a/src/LLVM/ExecutionEngine/Engine.hs +++ b/src/LLVM/ExecutionEngine/Engine.hs @@ -7,8 +7,8 @@ module LLVM.ExecutionEngine.Engine( EngineAccess, runEngineAccess, runEngineAccessWithModule, - createExecutionEngine, addModuleProvider, - createExecutionEngineForModule, addModule, + addModuleProvider, addModule, + runEngineAccessInterpreterWithModule, getExecutionEngineTargetData, getPointerToFunction, addFunctionValue, addGlobalMappings, @@ -30,14 +30,15 @@ import qualified LLVM.FFI.ExecutionEngine as FFI import qualified LLVM.FFI.Target as FFI -import qualified LLVM.FFI.Core as FFI(ModuleProviderRef, ValueRef) +import qualified LLVM.FFI.Core as FFI + (ModuleProviderRef, ValueRef, consBool, deconsBool, ) import qualified Control.Monad.Trans.State as MS import Control.Monad.IO.Class (MonadIO, liftIO, ) import Control.Monad (liftM, ) -import Control.Applicative (Applicative, ) -import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar, ) +import Control.Applicative (Applicative, pure, (<*>), ) +import qualified Data.EnumSet as EnumSet import Data.Typeable (Typeable) import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word8, Word16, Word32, Word64) @@ -45,7 +46,6 @@ import Foreign.Marshal.Alloc (alloca, free) import Foreign.Marshal.Array (withArrayLen) import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr) -import Foreign.Marshal.Utils (fromBool) import Foreign.C.String (peekCString) import Foreign.Ptr (Ptr, FunPtr, ) import Foreign.Storable (peek) @@ -53,21 +53,22 @@ import System.IO.Unsafe (unsafePerformIO) --- This global variable holds the one and only execution engine. --- It may be missing, but it never dies. --- XXX We could provide a destructor, what about functions obtained by runFunction? -{-# NOINLINE theEngine #-} -theEngine :: MVar (Maybe FFI.ExecutionEngineRef) -theEngine = unsafePerformIO $ newMVar Nothing - -createExecutionEngineGen :: - (Ptr FFI.ExecutionEngineRef -> ptr -> Ptr U.CString -> IO Bool) -> - ptr -> IO FFI.ExecutionEngineRef -createExecutionEngineGen create mPtr = +createExecutionEngineForModule :: + Bool -> FFI.EngineKindSet -> Module -> IO FFI.ExecutionEngineRef +createExecutionEngineForModule hostCPU kind m = alloca $ \eePtr -> alloca $ \errPtr -> do - success <- create eePtr mPtr errPtr - if success + success <- + withModule m $ \mPtr -> + if hostCPU + then + FFI.createExecutionEngineKindForModuleCPU + eePtr kind mPtr errPtr + else + if EnumSet.get FFI.JIT kind + then FFI.createExecutionEngineForModule eePtr mPtr errPtr + else FFI.createInterpreterForModule eePtr mPtr errPtr + if FFI.deconsBool success then do err <- peek errPtr errStr <- peekCString err @@ -76,28 +77,8 @@ else peek eePtr -createExecutionEngine :: ModuleProvider -> IO FFI.ExecutionEngineRef -createExecutionEngine prov = - withModuleProvider prov $ - createExecutionEngineGen - (\eePtr provPtr errPtr -> - fmap (0/=) $ FFI.createExecutionEngine eePtr provPtr errPtr) - -createExecutionEngineForModule :: Module -> IO FFI.ExecutionEngineRef -createExecutionEngineForModule m = - withModule m $ - createExecutionEngineGen FFI.createExecutionEngineForModuleCPU - -getTheEngine :: IO Module -> IO FFI.ExecutionEngineRef -getTheEngine getModule = do - mee <- takeMVar theEngine - case mee of - Just ee -> do putMVar theEngine mee; return ee - Nothing -> do - m <- getModule - ee <- createExecutionEngineForModule m - putMVar theEngine (Just ee) - return ee +getTheEngine :: FFI.EngineKindSet -> Module -> IO FFI.ExecutionEngineRef +getTheEngine = createExecutionEngineForModule True data EAState = EAState { ea_engine :: FFI.ExecutionEngineRef, @@ -113,15 +94,20 @@ -- so access to it is wrapped in a monad. runEngineAccess :: EngineAccess a -> IO a runEngineAccess (EA body) = do - eePtr <- getTheEngine $ createModule "__empty__" + eePtr <- getTheEngine FFI.kindEither =<< createModule "__empty__" MS.evalStateT body $ EAState { ea_engine = eePtr, ea_providers = [] } -- XXX should remove module providers again runEngineAccessWithModule :: Module -> EngineAccess a -> IO a runEngineAccessWithModule m (EA body) = do - eePtr <- getTheEngine $ return m + eePtr <- getTheEngine FFI.kindEither m MS.evalStateT body $ EAState { ea_engine = eePtr, ea_providers = [] } +runEngineAccessInterpreterWithModule :: Module -> EngineAccess a -> IO a +runEngineAccessInterpreterWithModule m (EA body) = do + eePtr <- getTheEngine FFI.kindInterpreter m + MS.evalStateT body $ EAState { ea_engine = eePtr, ea_providers = [] } + addModuleProvider :: ModuleProvider -> EngineAccess () addModuleProvider prov = do ea <- EA MS.get @@ -208,17 +194,15 @@ withAll ps a = go [] ps where go ptrs (x:xs) = withGenericValue x $ \ptr -> go (ptr:ptrs) xs go ptrs _ = withArrayLen (reverse ptrs) a - + runFunction :: U.Function -> [GenericValue] -> EngineAccess GenericValue -runFunction func args = do - eePtr <- getEngine - liftIO $ withAll args $ \argLen argPtr -> - createGenericValueWith $ FFI.runFunction eePtr func - (fromIntegral argLen) argPtr +runFunction func args = + liftIO =<< getRunFunction <*> pure func <*> pure args + getRunFunction :: EngineAccess (U.Function -> [GenericValue] -> IO GenericValue) getRunFunction = do eePtr <- getEngine - return $ \ func args -> + return $ \ func args -> withAll args $ \argLen argPtr -> createGenericValueWith $ FFI.runFunction eePtr func (fromIntegral argLen) argPtr @@ -235,15 +219,15 @@ toGenericInt signed val = unsafePerformIO $ createGenericValueWith $ do typ <- typeRef $ Proxy.fromValue val FFI.createGenericValueOfInt - typ (fromIntegral val) (fromBool signed) + typ (fromIntegral val) (FFI.consBool signed) fromGenericInt :: (Integral a, IsFirstClass a) => Bool -> GenericValue -> a fromGenericInt signed val = unsafePerformIO $ withGenericValue val $ \ref -> - fmap fromIntegral $ FFI.genericValueToInt ref (fromBool signed) + fmap fromIntegral $ FFI.genericValueToInt ref (FFI.consBool signed) --instance Generic Bool where --- toGeneric = toGenericInt False . fromBool +-- toGeneric = toGenericInt False . FFI.consBool -- fromGeneric = toBool . fromGenericInt False instance Generic Int8 where 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 @@ -54,7 +54,7 @@ makeTargetData r = TargetData { aBIAlignmentOfType = fromIntegral . unsafePerformIO . FFI.aBIAlignmentOfType r, aBISizeOfType = fromIntegral . unsafePerformIO . FFI.aBISizeOfType r, - littleEndian = unsafePerformIO (FFI.byteOrder r) /= 0, + littleEndian = unsafePerformIO (FFI.byteOrder r) /= FFI.bigEndian, callFrameAlignmentOfType = fromIntegral . unsafePerformIO . FFI.callFrameAlignmentOfType r, intPtrType = unsafePerformIO $ FFI.intPtrType r, pointerSize = fromIntegral $ unsafePerformIO $ FFI.pointerSize r, diff --git a/src/LLVM/Util/Optimize.hs b/src/LLVM/Util/Optimize.hs --- a/src/LLVM/Util/Optimize.hs +++ b/src/LLVM/Util/Optimize.hs @@ -47,7 +47,7 @@ getObjList withModule FFI.getFirstFunction FFI.getNextFunction mdl) mchanged <- FFI.runPassManager mpasses m - return $ any (>0) $ mchanged : fchanged + return $ any FFI.deconsBool $ mchanged : fchanged {- ToDo: