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: 16.0 +Version: 17.0 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: 16.0 + Tag: 17.0 Type: darcs Location: http://code.haskell.org/~thielema/llvm-tf/ @@ -53,7 +53,7 @@ Library private Default-Language: Haskell98 Build-Depends: - llvm-ffi >=15.0 && <17.0, + llvm-ffi >=17.0 && <18.0, tfp >=1.0 && <1.1, transformers >=0.3 && <0.7, storable-record >=0.0.2 && <0.1, diff --git a/private/LLVM/Core/Instructions.hs b/private/LLVM/Core/Instructions.hs --- a/private/LLVM/Core/Instructions.hs +++ b/private/LLVM/Core/Instructions.hs @@ -1191,8 +1191,7 @@ -> Value (Ptr a) -- ^ Address to store to. -> CodeGenFunction r () store (Value v) (Value p) = do - withCurrentBuilder_ $ \ bldPtr -> - FFI.buildStore bldPtr v p + withCurrentBuilder_ $ \ bldPtr -> FFI.buildStore bldPtr v p return () -- | Address arithmetic. See LLVM description. diff --git a/private/LLVM/Core/Instructions/Guided.hs b/private/LLVM/Core/Instructions/Guided.hs --- a/private/LLVM/Core/Instructions/Guided.hs +++ b/private/LLVM/Core/Instructions/Guided.hs @@ -52,7 +52,7 @@ import qualified LLVM.Core.Proxy as LP import LLVM.Core.Instructions.Private (ValueCons, proxyFromValuePtr) import LLVM.Core.CodeGenMonad (CodeGenFunction) -import LLVM.Core.CodeGen (ConstValue, zero) +import LLVM.Core.CodeGen (ConstValue, Value, zero) import LLVM.Core.Data (Ptr) import LLVM.Core.Type (IsArithmetic, IsInteger, IsIntegerOrPointer, IsFloating, @@ -276,11 +276,10 @@ select :: - (ValueCons value, IsPrimitive a, - Type shape a ~ av, Type shape Bool ~ bv) => + (IsPrimitive a, Type shape a ~ av, Type shape Bool ~ bv) => Guide shape a -> - value bv -> value av -> value av -> CodeGenFunction r (value av) -select Guide = Priv.trinop FFI.constSelect FFI.buildSelect + Value bv -> Value av -> Value av -> CodeGenFunction r (Value av) +select Guide = Priv.trinopValue FFI.buildSelect cmp :: diff --git a/private/LLVM/Core/Instructions/Private.hs b/private/LLVM/Core/Instructions/Private.hs --- a/private/LLVM/Core/Instructions/Private.hs +++ b/private/LLVM/Core/Instructions/Private.hs @@ -154,10 +154,15 @@ switchValueCons (TrinOp $ \(ConstValue a) (ConstValue b) (ConstValue c) -> liftIO $ fmap ConstValue $ cop a b c) - (TrinOp $ \(Value a) (Value b) (Value c) -> - liftM Value $ - withCurrentBuilder $ \ bld -> - U.withEmptyCString $ op bld a b c) + (TrinOp $ trinopValue op) + +trinopValue :: + FFITrinOp -> + Value a -> Value b -> Value c -> CodeGenFunction r (Value d) +trinopValue op (Value a) (Value b) (Value c) = + liftM Value $ + withCurrentBuilder $ \ bld -> + U.withEmptyCString $ op bld a b c diff --git a/private/LLVM/Core/Util.hs b/private/LLVM/Core/Util.hs --- a/private/LLVM/Core/Util.hs +++ b/private/LLVM/Core/Util.hs @@ -7,7 +7,6 @@ getModuleValues, getFunctions, getGlobalVariables, valueHasType, -- * Pass manager handling PassManager(..), withPassManager, createPassManager, createFunctionPassManager, - runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager, -- * Instruction builder Builder(..), withBuilder, createBuilder, positionAtEnd, getInsertBlock, -- * Basic blocks @@ -34,15 +33,11 @@ functionType, buildEmptyPhi, addPhiIns, showTypeOf, getValueNameU, getObjList, annotateValueList, isConstant, isIntrinsic, - -- * Transformation passes - addCFGSimplificationPass, addDemoteMemoryToRegisterPass, - addGVNPass, addInstructionCombiningPass, addPromoteMemoryToRegisterPass, addReassociatePass, ) where import qualified LLVM.FFI.Core as FFI import qualified LLVM.FFI.BitWriter as FFI import qualified LLVM.FFI.BitReader as FFI -import qualified LLVM.FFI.Transforms.Scalar as FFI import Foreign.C.String (withCString, withCStringLen, CString, peekCString) import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr) @@ -367,35 +362,6 @@ withModule modul $ \modulPtr -> do ptr <- FFI.createFunctionPassManagerForModule modulPtr liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr - --- | Add a control flow graph simplification pass to the manager. -addCFGSimplificationPass :: PassManager -> IO () -addCFGSimplificationPass pm = withPassManager pm FFI.addCFGSimplificationPass - -addDemoteMemoryToRegisterPass :: PassManager -> IO () -addDemoteMemoryToRegisterPass pm = withPassManager pm FFI.addDemoteMemoryToRegisterPass - --- | Add a global value numbering pass to the manager. -addGVNPass :: PassManager -> IO () -addGVNPass pm = withPassManager pm FFI.addGVNPass - -addInstructionCombiningPass :: PassManager -> IO () -addInstructionCombiningPass pm = withPassManager pm FFI.addInstructionCombiningPass - -addPromoteMemoryToRegisterPass :: PassManager -> IO () -addPromoteMemoryToRegisterPass pm = withPassManager pm FFI.addPromoteMemoryToRegisterPass - -addReassociatePass :: PassManager -> IO () -addReassociatePass pm = withPassManager pm FFI.addReassociatePass - -runFunctionPassManager :: PassManager -> Function -> IO FFI.Bool -runFunctionPassManager pm fcn = withPassManager pm $ \ pmref -> FFI.runFunctionPassManager pmref fcn - -initializeFunctionPassManager :: PassManager -> IO FFI.Bool -initializeFunctionPassManager pm = withPassManager pm FFI.initializeFunctionPassManager - -finalizeFunctionPassManager :: PassManager -> IO FFI.Bool -finalizeFunctionPassManager pm = withPassManager pm FFI.finalizeFunctionPassManager -------------------------------------- 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,17 +1,39 @@ module LLVM.Util.Optimize(optimizeModule) where -import LLVM.Core.Util (Module, withModule, getObjList) +import LLVM.Core.Util (Module, withModule) -import qualified LLVM.FFI.Transforms.PassManagerBuilder as PMB +import qualified LLVM.FFI.Transforms.PassBuilder as PB +import qualified LLVM.FFI.TargetMachine as TM +import qualified LLVM.FFI.Error as Error import qualified LLVM.FFI.Core as FFI -import LLVM.FFI.Transforms.Scalar (addVerifierPass) -import Control.Exception (bracket, bracket_) +import qualified Foreign.Marshal.Alloc as Alloc +import qualified Foreign.C.String as CStr +import Foreign.C.String (withCString) +import Foreign.Storable (peek) +import Foreign.Ptr (Ptr, nullPtr) +import Control.Exception (bracket) +import Control.Monad (when) -{- | -Result tells whether the module was modified by any of the passes. +import Text.Printf (printf) + +failFromError :: Ptr CStr.CString -> IO a +failFromError errorRef = + bracket (peek errorRef) Alloc.free $ \errorMsg -> + CStr.peekCString errorMsg >>= fail + +getTargetFromTriple :: TM.Triple -> IO TM.TargetRef +getTargetFromTriple triple = + Alloc.alloca $ \targetRef -> + Alloc.alloca $ \errorRef -> do + failure <- TM.getTargetFromTriple triple targetRef errorRef + if FFI.deconsBool failure + then failFromError errorRef + else peek targetRef + +{- | It is very important that you set target triple and target data layout before optimizing. Otherwise the optimizer will make wrong assumptions @@ -21,42 +43,33 @@ In the future I might enforce via types that you set target parameters before optimization. -} -optimizeModule :: Int -> Module -> IO Bool +optimizeModule :: Int -> Module -> IO () optimizeModule optLevel mdl = - withModule mdl $ \ m -> - {- - Core.Util.createPassManager would provide a finalizer for us, - but I think it is better here to immediately dispose the manager - when we need it no longer. - -} - bracket FFI.createPassManager FFI.disposePassManager $ \mpasses -> - bracket (FFI.createFunctionPassManagerForModule m) - FFI.disposePassManager $ \fpasses -> do - addVerifierPass mpasses + withModule mdl $ \ modul -> - 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 - -} + (FFI.getTarget modul >>=) $ \triple -> + (getTargetFromTriple triple >>=) $ \target -> + (TM.getHostCPUName >>=) $ \cpu -> + withCString "" $ \features -> - PMB.populateFunctionPassManager passBuilder fpasses - PMB.populateModulePassManager passBuilder mpasses + bracket + (TM.createTargetMachine target triple cpu features + TM.codeGenLevelDefault TM.relocDefault TM.codeModelDefault) + TM.disposeTargetMachine $ + \tm -> - 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 FFI.deconsBool $ mchanged : fchanged + bracket PB.createPassBuilderOptions PB.disposePassBuilderOptions $ + \pbOpt -> + + withCString (printf "default" optLevel) $ \passName -> do + PB.passBuilderOptionsSetVerifyEach pbOpt FFI.true + errorRef <- PB.runPasses modul passName tm pbOpt + when (errorRef /= nullPtr) $ + bracket + (Error.getErrorMessage errorRef) + Error.disposeErrorMessage + $ \errorMsg -> + CStr.peekCString errorMsg >>= fail {- ToDo: