diff --git a/example/Array.hs b/example/Array.hs --- a/example/Array.hs +++ b/example/Array.hs @@ -58,7 +58,7 @@ -- Initialize jitter initializeNativeTarget m <- newModule - _f <- defineModule m cg + _f <- defineModule m $ setTarget hostTriple >> cg writeBitcodeToFile "Arr.bc" m _ <- optimizeModule 3 m writeBitcodeToFile "Arr-opt.bc" m diff --git a/example/CallConv.hs b/example/CallConv.hs --- a/example/CallConv.hs +++ b/example/CallConv.hs @@ -15,7 +15,7 @@ main :: IO () main = do m <- newModule - _fns <- defineModule m buildMod + _fns <- defineModule m $ setTarget hostTriple >> buildMod --_ <- optimizeModule 3 m writeBitcodeToFile "CallConv.bc" m return () diff --git a/example/Fibonacci.hs b/example/Fibonacci.hs --- a/example/Fibonacci.hs +++ b/example/Fibonacci.hs @@ -41,8 +41,7 @@ -- Generate code for mfib, and then throw away the IO in the type. -- The result is an ordinary Haskell function. - iofib <- EE.runEngineAccess $ do - EE.addModule m + iofib <- EE.runEngineAccessWithModule m $ EE.generateFunction $ mfib fns let fib = EE.unsafeRemoveIO iofib diff --git a/example/Intrinsic.hs b/example/Intrinsic.hs new file mode 100644 --- /dev/null +++ b/example/Intrinsic.hs @@ -0,0 +1,67 @@ +module Main where + +import qualified LLVM.Core as LLVM +import qualified LLVM.ExecutionEngine as EE + +import qualified Foreign.Marshal.Utils as MU +import Foreign.Marshal.Alloc (alloca, ) +import Foreign.Storable (Storable, peek, ) +import Foreign.Ptr (Ptr, ) + +import qualified Type.Data.Num.Decimal as TypeNum +import qualified Data.Word as W + +import qualified Data.NonEmpty.Class as NonEmptyC + + +type Vector4 = LLVM.Vector TypeNum.D4 Float +type Vector8 = LLVM.Vector TypeNum.D8 Float +type Vector = Vector4 + +vector :: Vector +vector = LLVM.vector $ NonEmptyC.iterate (1.2+) (-1.7 :: Float) + +roundpsExtern4 :: + LLVM.CodeGenFunction r + (LLVM.Function (Vector4 -> W.Word32 -> IO Vector4)) +roundpsExtern4 = + LLVM.externFunction "llvm.x86.sse41.round.ps" + +roundpsExtern8 :: + LLVM.CodeGenFunction r + (LLVM.Function (Vector8 -> W.Word32 -> IO Vector8)) +roundpsExtern8 = + LLVM.externFunction "llvm.x86.avx.round.ps.256" + +roundps :: + LLVM.Value Vector -> LLVM.Value W.Word32 -> + LLVM.CodeGenFunction s (LLVM.Value Vector) +roundps xs mode = do + f <- roundpsExtern4 + LLVM.call f xs mode + +modul :: + LLVM.CodeGenModule (LLVM.Function (Ptr Vector -> Ptr Vector -> IO ())) +modul = + LLVM.createFunction LLVM.ExternalLinkage $ \ptr0 ptr1 -> do + flip LLVM.store ptr1 =<< flip roundps (LLVM.valueOf 1) =<< LLVM.load ptr0 + LLVM.ret () + +run :: IO () +run = do + m <- LLVM.newModule + _f <- LLVM.defineModule m $ LLVM.setTarget LLVM.hostTriple >> modul + LLVM.writeBitcodeToFile "floor.bc" m + + print vector + floorFunc <- EE.simpleFunction modul + MU.with vector $ \ptr0 -> + alloca $ \ptr1 -> do + floorFunc ptr0 ptr1 + print =<< peek ptr1 + + +main :: IO () +main = do + LLVM.initializeNativeTarget + run diff --git a/example/List.hs b/example/List.hs --- a/example/List.hs +++ b/example/List.hs @@ -74,7 +74,7 @@ renderList :: IO () renderList = do m <- newModule - _f <- defineModule m mList + _f <- defineModule m $ setTarget hostTriple >> mList writeBitcodeToFile "List.bc" m fill <- simpleFunction mList diff --git a/example/Vector.hs b/example/Vector.hs --- a/example/Vector.hs +++ b/example/Vector.hs @@ -4,7 +4,7 @@ import Convert import LLVM.ExecutionEngine - (runEngineAccess, addModule, generateFunction, getPointerToFunction) + (runEngineAccessWithModule, generateFunction, getPointerToFunction) import LLVM.Util.Optimize (optimizeModule, ) import LLVM.Util.Loop (forLoop, ) import LLVM.Core @@ -73,14 +73,14 @@ initializeNativeTarget -- First run standard code. m <- newModule - iovec <- defineModule m cgvec + iovec <- defineModule m $ setTarget hostTriple >> cgvec - fptr <- runEngineAccess $ do addModule m; getPointerToFunction iovec + fptr <- runEngineAccessWithModule m $ getPointerToFunction iovec let fvec = convert fptr fvec 10 >>= print - vec <- runEngineAccess $ do addModule m; generateFunction iovec + vec <- runEngineAccessWithModule m $ generateFunction iovec vec 10 >>= print @@ -95,8 +95,8 @@ ioretacc' :: Function (IO T) Just ioretacc' = castModuleValue =<< lookup retAccName funcs - (vec', retacc') <- runEngineAccess $ do - addModule m + (vec', retacc') <- + runEngineAccessWithModule m $ liftM2 (,) (generateFunction iovec') (generateFunction ioretacc') dumpValue iovec' 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.1.9 +Version: 3.0.3.2 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.1.9 + Tag: 3.0.3.2 Type: darcs Location: http://code.haskell.org/~thielema/llvm-tf/ @@ -53,7 +53,7 @@ Library Default-Language: Haskell98 Build-Depends: - llvm-ffi >= 3.0 && <3.6, + llvm-ffi >= 3.5.1 && <3.6, tfp >=1.0 && <1.1, transformers >=0.3 && <0.6, process >=1.1 && <1.5, @@ -204,6 +204,20 @@ Buildable: False Main-Is: example/HelloJIT.hs + Default-Language: Haskell98 + GHC-Options: -Wall + +Executable llvm-intrinsic + If flag(buildExamples) + Build-Depends: + llvm-tf, + tfp, + non-empty, + base + Else + Buildable: False + + Main-Is: example/Intrinsic.hs Default-Language: Haskell98 GHC-Options: -Wall diff --git a/src/LLVM/Core.hs b/src/LLVM/Core.hs --- a/src/LLVM/Core.hs +++ b/src/LLVM/Core.hs @@ -28,9 +28,10 @@ -- @newNamedX@ function; the @newX@ function just generates a fresh name. module LLVM.Core( -- * Initialize - initializeNativeTarget, + Target.initializeNativeTarget, -- * Modules Module, newModule, newNamedModule, defineModule, destroyModule, createModule, + setTarget, FFI.hostTriple, ModuleProvider, createModuleProviderForExistingModule, PassManager, createPassManager, createFunctionPassManager, writeBitcodeToFile, readBitcodeFromFile, @@ -76,6 +77,7 @@ dumpValue, dumpType, getValueName, annotateValueList ) where +import qualified LLVM.Target.Native as Target import LLVM.Core.Util hiding (Function, BasicBlock, createModule, constString, constStringNul, constVector, constArray, constStruct, getModuleValues, valueHasType) import LLVM.Core.CodeGen import LLVM.Core.CodeGenMonad @@ -85,7 +87,6 @@ import LLVM.Core.Instructions import LLVM.Core.Type import LLVM.Core.Vector -import LLVM.Target.Native import qualified LLVM.FFI.Core as FFI 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 @@ -7,7 +7,7 @@ module LLVM.Core.CodeGen( -- * Module creation newModule, newNamedModule, defineModule, createModule, - getModuleValues, ModuleValue, castModuleValue, + getModuleValues, ModuleValue, castModuleValue, setTarget, -- * Globals Linkage(..), Visibility(..), @@ -51,6 +51,7 @@ import Type.Base.Proxy (Proxy) import qualified Foreign.Storable as St +import Foreign.C.String (withCString) import Foreign.StablePtr (StablePtr, castStablePtrToPtr) import Foreign.Ptr (Ptr, minusPtr, nullPtr, FunPtr, castFunPtrToPtr) import System.IO.Unsafe (unsafePerformIO) @@ -86,6 +87,12 @@ createModule :: CodeGenModule a -- ^ module body -> IO a createModule cgm = newModule >>= \ m -> defineModule m cgm + +setTarget :: String -> CodeGenModule () +setTarget triple = do + modul <- getModule + liftIO $ U.withModule modul $ \m -> withCString triple $ FFI.setTarget m + -------------------------------------- diff --git a/src/LLVM/ExecutionEngine.hs b/src/LLVM/ExecutionEngine.hs --- a/src/LLVM/ExecutionEngine.hs +++ b/src/LLVM/ExecutionEngine.hs @@ -4,6 +4,7 @@ -- * Execution engine EngineAccess, runEngineAccess, + runEngineAccessWithModule, addModuleProvider, addModule, getPointerToFunction, @@ -22,16 +23,18 @@ -- * Target information module LLVM.ExecutionEngine.Target ) where -import System.IO.Unsafe (unsafePerformIO) import LLVM.ExecutionEngine.Engine import LLVM.ExecutionEngine.Target import LLVM.Core.CodeGen (Value(..)) import LLVM.Core + (CodeGenModule, Function, newModule, defineModule, getGlobalMappings) --import LLVM.Core.Util(runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager) import LLVM.FFI.Core (ValueRef) +import System.IO.Unsafe (unsafePerformIO) + import Control.Monad (liftM2, ) @@ -77,8 +80,7 @@ simpleFunction bld = do m <- newModule (func, mappings) <- defineModule m (liftM2 (,) bld getGlobalMappings) - runEngineAccess $ do - addModule m + runEngineAccessWithModule m $ do addGlobalMappings mappings generateFunction func 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 @@ -6,7 +6,7 @@ {-# LANGUAGE DeriveDataTypeable #-} module LLVM.ExecutionEngine.Engine( EngineAccess, - runEngineAccess, + runEngineAccess, runEngineAccessWithModule, createExecutionEngine, addModuleProvider, createExecutionEngineForModule, addModule, getExecutionEngineTargetData, @@ -86,15 +86,15 @@ createExecutionEngineForModule :: Module -> IO FFI.ExecutionEngineRef createExecutionEngineForModule m = withModule m $ - createExecutionEngineGen FFI.createExecutionEngineForModule + createExecutionEngineGen FFI.createExecutionEngineForModuleCPU -getTheEngine :: IO FFI.ExecutionEngineRef -getTheEngine = do +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 <- createModule "__empty__" + m <- getModule ee <- createExecutionEngineForModule m putMVar theEngine (Just ee) return ee @@ -113,9 +113,14 @@ -- so access to it is wrapped in a monad. runEngineAccess :: EngineAccess a -> IO a runEngineAccess (EA body) = do - eePtr <- getTheEngine + eePtr <- getTheEngine $ 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 + MS.evalStateT body $ EAState { ea_engine = eePtr, ea_providers = [] } addModuleProvider :: ModuleProvider -> EngineAccess () addModuleProvider prov = do 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 @@ -1,22 +1,12 @@ -{- -LLVM does not export its functions -@createStandardFunctionPasses@ and -@createStandardModulePasses@ via its C interface -and interfacing to C-C++ wrappers is not very portable. -Thus we reimplement these functions -from @opt.cpp@ and @StandardPasses.h@ in Haskell. -However this way we risk inconsistencies -between 'optimizeModule' and the @opt@ shell command. --} module LLVM.Util.Optimize(optimizeModule) where -import LLVM.Core.Util (Module, withModule) +import LLVM.Core.Util (Module, withModule, getObjList) +import qualified LLVM.FFI.Transforms.PassManagerBuilder as PMB import qualified LLVM.FFI.Core as FFI -import qualified LLVM.FFI.Support as FFI import LLVM.FFI.Transforms.Scalar (addVerifierPass) -import Control.Exception (bracket) +import Control.Exception (bracket, bracket_) {- | @@ -30,76 +20,34 @@ but I think it is better here to immediately dispose the manager when we need it no longer. -} - bracket FFI.createPassManager FFI.disposePassManager $ \ passes -> - -{- -Note on LLVM-2.6 to 2.8 (at least): -As far as I understand, if we do not set target data, -then the optimizer will only perform machine independent optimizations. -If we set target data -(e.g. an empty layout string obtained from a module without 'target data' specification.) -we risk that the optimizer switches to a wrong layout -(e.g. to 64 bit pointers on a 32 bit machine for empty layout string) -and thus generates corrupt code. - -Currently it seems to be safer to disable -machine dependent optimization completely. - -http://llvm.org/bugs/show_bug.cgi?id=6394 - - -- Pass the module target data to the pass manager. - target <- FFI.getDataLayout m >>= createTargetData - addTargetData target passes --} - - {- - opt.cpp does not use a FunctionPassManager for function optimization, - but a module PassManager. - Thus we do it the same way. - I assume that we would need a FunctionPassManager - only if we wanted to apply individual optimizations to functions. - - fPasses <- FFI.createFunctionPassManager mp - -} - bracket FFI.createPassManager FFI.disposePassManager $ \ fPasses -> do - -- add module target data? - - -- tools/opt/opt.cpp: AddStandardCompilePasses - addVerifierPass passes - addOptimizationPasses passes fPasses optLevel - - {- if we wanted to do so, we could loop through all functions and optimize them. - initializeFunctionPassManager fPasses - runFunctionPassManager fPasses fcn - -} - - functionsModified <- FFI.runPassManager fPasses m - - moduleModified <- FFI.runPassManager passes m - - return $ - toEnum (fromIntegral moduleModified) || - toEnum (fromIntegral functionsModified) - --- tools/opt/opt.cpp: AddOptimizationPasses -addOptimizationPasses :: FFI.PassManagerRef -> FFI.PassManagerRef -> Int -> IO () -addOptimizationPasses passes fPasses optLevel = do - createStandardFunctionPasses fPasses optLevel - createStandardModulePasses passes optLevel True True (optLevel > 1) True True True + bracket FFI.createPassManager FFI.disposePassManager $ \mpasses -> + bracket (FFI.createFunctionPassManagerForModule m) + FFI.disposePassManager $ \fpasses -> do + addVerifierPass mpasses -createStandardFunctionPasses :: FFI.PassManagerRef -> Int -> IO () -createStandardFunctionPasses fPasses optLevel = - FFI.createStandardFunctionPasses fPasses (fromIntegral optLevel) + bracket PMB.create PMB.dispose $ \passBuilder -> do + PMB.setOptLevel passBuilder $ fromIntegral optLevel + {- + PMB.setSizeLevel passBuilder 1 + PMB.setDisableUnitAtATime passBuilder false + PMB.setDisableUnrollLoops passBuilder (optLevel <= 1) + PMB.setDisableSimplifyLibCalls passBuilder false + PMB.setHaveExceptions passBuilder true + PMB.setInliningPass passBuilder true + -} --- llvm/Support/StandardPasses.h: createStandardModulePasses -createStandardModulePasses :: FFI.PassManagerRef -> Int -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IO () -createStandardModulePasses passes optLevel optSize unitAtATime unrollLoops simplifyLibCalls haveExceptions inliningPass = - FFI.createStandardModulePasses passes (fromIntegral optLevel) (f optSize) - (f unitAtATime) (f unrollLoops) (f simplifyLibCalls) (f haveExceptions) - (f (not inliningPass)) - where f True = 1 - f _ = 0 + PMB.populateFunctionPassManager passBuilder fpasses + PMB.populateModulePassManager passBuilder mpasses + fchanged <- + bracket_ + (FFI.initializeFunctionPassManager fpasses) + (FFI.finalizeFunctionPassManager fpasses) + (mapM (FFI.runFunctionPassManager fpasses) =<< + getObjList withModule + FFI.getFirstFunction FFI.getNextFunction mdl) + mchanged <- FFI.runPassManager mpasses m + return $ any (>0) $ mchanged : fchanged {- ToDo: