diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,12 @@ +## 6.0.0 (2018-03-06) + +* Support for LLVM 6.0, take a look at the changelog of llvm-hs-pure for details. +* Add `AggregateZero` for zero-initializing structs, arrays and vectors. Previously `Null` + was used for null pointers as well as zero-inializing aggregates. The new behavior reflects + LLVM’s internal representation and the C++-API. +* Enforce that `Null` is only used on pointer types. Existing uses of `Null` on arrays, structs and + vector must be changed to the newly introduced `AggregateZero`. + ## 5.1.3 (2018-01-06) * Add bindings to `loadLibraryPermamently` and `getSymbolAddressInProcess`. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -35,8 +35,13 @@ mkFlagName = FlagName #endif +#if !(MIN_VERSION_Cabal(2,1,0)) +lookupFlagAssignment :: FlagName -> FlagAssignment -> Maybe Bool +lookupFlagAssignment = lookup +#endif + llvmVersion :: Version -llvmVersion = mkVersion [5,0] +llvmVersion = mkVersion [6,0] llvmConfigNames :: [String] llvmConfigNames = [ @@ -88,21 +93,23 @@ -- | These flags are not relevant for us and dropping them allows -- linking against LLVM build with Clang using GCC ignoredCxxFlags :: [String] -ignoredCxxFlags = - ["-Wcovered-switch-default", "-fcolor-diagnostics"] ++ map ("-D" ++) uncheckedHsFFIDefines +ignoredCxxFlags = ["-fcolor-diagnostics"] ++ map ("-D" ++) uncheckedHsFFIDefines ignoredCFlags :: [String] -ignoredCFlags = ["-Wcovered-switch-default", "-Wdelete-non-virtual-dtor", "-fcolor-diagnostics"] +ignoredCFlags = ["-fcolor-diagnostics"] -- | Header directories are added separately to configExtraIncludeDirs isIncludeFlag :: String -> Bool isIncludeFlag flag = "-I" `isPrefixOf` flag +isWarningFlag :: String -> Bool +isWarningFlag flag = "-W" `isPrefixOf` flag + isIgnoredCFlag :: String -> Bool -isIgnoredCFlag flag = flag `elem` ignoredCFlags || isIncludeFlag flag +isIgnoredCFlag flag = flag `elem` ignoredCFlags || isIncludeFlag flag || isWarningFlag flag isIgnoredCxxFlag :: String -> Bool -isIgnoredCxxFlag flag = flag `elem` ignoredCxxFlags || isIncludeFlag flag +isIgnoredCxxFlag flag = flag `elem` ignoredCxxFlags || isIncludeFlag flag || isWarningFlag flag main :: IO () main = do @@ -125,7 +132,7 @@ [llvmVersion] <- liftM lines $ llvmConfig ["--version"] let getLibs = liftM (map (fromJust . stripPrefix "-l") . words) . llvmConfig flags = configConfigurationsFlags confFlags - linkFlag = case lookup (mkFlagName "shared-llvm") flags of + linkFlag = case lookupFlagAssignment (mkFlagName "shared-llvm") flags of Nothing -> "--link-shared" Just shared -> if shared then "--link-shared" else "--link-static" libs <- getLibs ["--libs", linkFlag] diff --git a/llvm-hs.cabal b/llvm-hs.cabal --- a/llvm-hs.cabal +++ b/llvm-hs.cabal @@ -1,5 +1,5 @@ name: llvm-hs -version: 5.1.3 +version: 6.0.0 license: BSD3 license-file: LICENSE author: Anthony Cowley, Stephen Diehl, Moritz Kiefer , Benjamin S. Scarlet @@ -80,7 +80,7 @@ template-haskell >= 2.5.0.0, containers >= 0.4.2.1, array >= 0.4.0.0, - llvm-hs-pure == 5.1.* + llvm-hs-pure == 6.0.* hs-source-dirs: src extensions: NoImplicitPrelude @@ -250,12 +250,12 @@ tasty-quickcheck >= 0.8, QuickCheck >= 2.5.1.1, llvm-hs, - llvm-hs-pure == 5.1.*, + llvm-hs-pure, containers >= 0.4.2.1, mtl >= 2.1, transformers >= 0.3.0.0, temporary >= 1.2 && < 1.3, - pretty-show >= 1.6 && < 1.7 + pretty-show >= 1.6 && < 1.8 hs-source-dirs: test extensions: TupleSections diff --git a/src/LLVM/Internal/Attribute.hs b/src/LLVM/Internal/Attribute.hs --- a/src/LLVM/Internal/Attribute.hs +++ b/src/LLVM/Internal/Attribute.hs @@ -96,6 +96,7 @@ A.FA.StackProtect -> FFI.functionAttributeKindStackProtect A.FA.StackProtectReq -> FFI.functionAttributeKindStackProtectReq A.FA.StackProtectStrong -> FFI.functionAttributeKindStackProtectStrong + A.FA.StrictFP -> FFI.functionAttributeKindStrictFP A.FA.NoRedZone -> FFI.functionAttributeKindNoRedZone A.FA.NoImplicitFloat -> FFI.functionAttributeKindNoImplicitFloat A.FA.Naked -> FFI.functionAttributeKindNaked @@ -109,6 +110,7 @@ A.FA.JumpTable -> FFI.functionAttributeKindJumpTable A.FA.NoDuplicate -> FFI.functionAttributeKindNoDuplicate A.FA.SanitizeAddress -> FFI.functionAttributeKindSanitizeAddress + A.FA.SanitizeHWAddress -> FFI.functionAttributeKindSanitizeHWAddress A.FA.SanitizeThread -> FFI.functionAttributeKindSanitizeThread A.FA.SanitizeMemory -> FFI.functionAttributeKindSanitizeMemory A.FA.SafeStack -> FFI.functionAttributeKindSafeStack @@ -181,6 +183,7 @@ [functionAttributeKindP|StackProtect|] -> return A.FA.StackProtect [functionAttributeKindP|StackProtectReq|] -> return A.FA.StackProtectReq [functionAttributeKindP|StackProtectStrong|] -> return A.FA.StackProtectStrong + [functionAttributeKindP|StrictFP|] -> return A.FA.StrictFP [functionAttributeKindP|NoRedZone|] -> return A.FA.NoRedZone [functionAttributeKindP|NoImplicitFloat|] -> return A.FA.NoImplicitFloat [functionAttributeKindP|Naked|] -> return A.FA.Naked @@ -195,6 +198,7 @@ [functionAttributeKindP|JumpTable|] -> return A.FA.JumpTable [functionAttributeKindP|NoDuplicate|] -> return A.FA.NoDuplicate [functionAttributeKindP|SanitizeAddress|] -> return A.FA.SanitizeAddress + [functionAttributeKindP|SanitizeHWAddress|] -> return A.FA.SanitizeHWAddress [functionAttributeKindP|SanitizeThread|] -> return A.FA.SanitizeThread [functionAttributeKindP|SanitizeMemory|] -> return A.FA.SanitizeMemory [functionAttributeKindP|ArgMemOnly|] -> return A.FA.ArgMemOnly diff --git a/src/LLVM/Internal/Constant.hs b/src/LLVM/Internal/Constant.hs --- a/src/LLVM/Internal/Constant.hs +++ b/src/LLVM/Internal/Constant.hs @@ -64,7 +64,7 @@ t <- encodeM (A.IntegerType bits) words <- encodeM [ fromIntegral ((v `shiftR` (w*64)) .&. 0xffffffffffffffff) :: Word64 - | w <- [0 .. ((fromIntegral bits-1) `div` 64)] + | w <- [0 .. ((fromIntegral bits-1) `div` 64)] ] liftIO $ FFI.constantIntOfArbitraryPrecision t words A.C.Float { A.C.floatValue = v } -> do @@ -102,7 +102,7 @@ if ty /= ty' then throwM (EncodeException - ("The serialized GlobalReference has type " ++ show ty' ++ " but should have type " ++ show ty)) + ("The serialized GlobalReference " ++ show n ++ " has type " ++ show ty ++ " but should have type " ++ show ty')) else return ref A.C.BlockAddress f b -> do f' <- referGlobal f @@ -122,7 +122,10 @@ Context context <- gets encodeStateContext liftIO $ FFI.getConstTokenNone context o -> $(do - let constExprInfo = ID.outerJoin ID.astConstantRecs (ID.innerJoin ID.astInstructionRecs ID.instructionDefs) + let -- This is a mapping from constructor names to the constructor of the constant + -- and the constructor and the definition of the instruction. + constExprInfo :: Map.Map String (Maybe TH.Con, Maybe (TH.Con, ID.InstructionDef)) + constExprInfo = ID.outerJoin ID.astConstantRecs (ID.innerJoin ID.astInstructionRecs ID.instructionDefs) TH.caseE [| o |] $ map (\p -> TH.match p (TH.normalB [|inconsistentCases "Constant" o|]) []) [[p|A.C.Int{}|], @@ -131,26 +134,62 @@ [p|A.C.BlockAddress{}|], [p|A.C.GlobalReference{}|], [p|A.C.TokenNone{}|]] ++ - (do (name, (Just (TH.RecC n fs), instrInfo)) <- Map.toList constExprInfo - let fns = [ TH.mkName . TH.nameBase $ fn | (fn, _, _) <- fs ] + (do (name, (Just (TH.RecC n fields), instrInfo)) <- Map.toList constExprInfo + let fieldNames = [ TH.mkName . TH.nameBase $ fn | (fn, _, _) <- fields ] coreCall n = TH.dyn $ "FFI.constant" ++ n - buildBody c = [ TH.bindS (TH.varP fn) [| encodeM $(TH.varE fn) |] | fn <- fns ] - ++ [ TH.noBindS [| liftIO $(foldl TH.appE c (map TH.varE fns)) |] ] - hasFlags = any (== ''Bool) [ h | (_, _, TH.ConT h) <- fs ] + -- Addition validations that are run during encoding. A common usage of + -- this is to check if certain types are allowed. The record fields are in scope + -- when the validations are run. + validations = case name of + "Null" -> + [ TH.noBindS + [| case $(TH.dyn "constantType") of + A.PointerType {} -> pure () + _ -> + throwM + (EncodeException + ("Null pointer constant must have pointer type but has type " <> + show $(TH.dyn "constantType") <> ".")) + |] + ] + "AggregateZero" -> + [ TH.noBindS $ + [| case $(TH.dyn "constantType") of + A.ArrayType {} -> pure () + A.StructureType {} -> pure () + A.VectorType {} -> pure () + _ -> + throwM + (EncodeException + ("Aggregate zero constant must have struct, array or vector type but has type " <> + show $(TH.dyn "constantType") <> ".")) + |] + ] + _ -> [] + buildBody c = + validations ++ + [ TH.bindS (TH.varP fn) [| encodeM $(TH.varE fn) |] | fn <- fieldNames ] ++ + [ TH.noBindS [| liftIO $(foldl TH.appE c (map TH.varE fieldNames)) |] ] + hasFlags = ''Bool `elem` [ h | (_, _, TH.ConT h) <- fields ] core <- case instrInfo of Just (_, iDef) -> do let opcode = TH.dataToExpQ (const Nothing) (ID.cppOpcode iDef) case ID.instructionKind iDef of - ID.Binary | hasFlags -> return $ coreCall name - | True -> return [| $(coreCall "BinaryOperator") $(opcode) |] + ID.Binary + | hasFlags -> return $ coreCall name + | otherwise -> return [| $(coreCall "BinaryOperator") $(opcode) |] ID.Cast -> return [| $(coreCall "Cast") $(opcode) |] _ -> return $ coreCall name Nothing -> - if (name `elem` ["Vector", "Null", "Array", "Undef"]) - then return $ coreCall name - else [] + case name of + "Array" -> pure (TH.varE 'FFI.constantArray) + "AggregateZero" -> pure (TH.varE 'FFI.constantNull) + "Null" -> pure (TH.varE 'FFI.constantNull) + "Undef" -> pure (TH.varE 'FFI.constantUndef) + "Vector" -> pure (TH.varE 'FFI.constantVector) + _ -> [] -- We have already handled these values return $ TH.match - (TH.recP n [(fn,) <$> (TH.varP . TH.mkName . TH.nameBase $ fn) | (fn, _, _) <- fs]) + (TH.recP n [(fn,) <$> (TH.varP . TH.mkName . TH.nameBase $ fn) | (fn, _, _) <- fields]) (TH.normalB (TH.doE (buildBody core))) []) ) @@ -163,11 +202,11 @@ t <- decodeM ft valueSubclassId <- liftIO $ FFI.getValueSubclassId v nOps <- liftIO $ FFI.getNumOperands u - let globalRef = return A.C.GlobalReference + let globalRef = return A.C.GlobalReference `ap` (return t) `ap` (getGlobalName =<< liftIO (FFI.isAGlobalValue v)) op = decodeM <=< liftIO . FFI.getConstantOperand c - getConstantOperands = mapM op [0..nOps-1] + getConstantOperands = mapM op [0..nOps-1] getConstantData = do let nElements = case t of @@ -208,10 +247,10 @@ A.PPC_FP128FP -> A.F.PPC_FP128 <$> peekByteOff (castPtr ws) 8 <*> peekByteOff (castPtr ws) 0 ) [valueSubclassIdP|ConstantPointerNull|] -> return $ A.C.Null t - [valueSubclassIdP|ConstantAggregateZero|] -> return $ A.C.Null t + [valueSubclassIdP|ConstantAggregateZero|] -> return $ A.C.AggregateZero t [valueSubclassIdP|UndefValue|] -> return $ A.C.Undef t - [valueSubclassIdP|BlockAddress|] -> - return A.C.BlockAddress + [valueSubclassIdP|BlockAddress|] -> + return A.C.BlockAddress `ap` (getGlobalName =<< do liftIO $ FFI.isAGlobalValue =<< FFI.getBlockAddressFunction c) `ap` (getLocalName =<< do liftIO $ FFI.getBlockAddressBlock c) [valueSubclassIdP|ConstantStruct|] -> do @@ -219,11 +258,11 @@ `ap` (return $ case t of A.NamedTypeReference n -> Just n; _ -> Nothing) `ap` (decodeM =<< liftIO (FFI.isPackedStruct ft)) `ap` getConstantOperands - [valueSubclassIdP|ConstantDataArray|] -> + [valueSubclassIdP|ConstantDataArray|] -> return A.C.Array `ap` (return $ A.elementType t) `ap` getConstantData - [valueSubclassIdP|ConstantArray|] -> + [valueSubclassIdP|ConstantArray|] -> return A.C.Array `ap` (return $ A.elementType t) `ap` getConstantOperands - [valueSubclassIdP|ConstantDataVector|] -> + [valueSubclassIdP|ConstantDataVector|] -> return A.C.Vector `ap` getConstantData [valueSubclassIdP|ConstantVector|] -> A.C.Vector <$> getConstantOperands @@ -277,5 +316,5 @@ _ -> error $ "unhandled constant valueSubclassId: " ++ show valueSubclassId - - + + diff --git a/src/LLVM/Internal/DecodeAST.hs b/src/LLVM/Internal/DecodeAST.hs --- a/src/LLVM/Internal/DecodeAST.hs +++ b/src/LLVM/Internal/DecodeAST.hs @@ -177,4 +177,6 @@ let r = A.A.GroupID (fromIntegral (length ids)) modify $ \s -> s { functionAttributeListIDs = (p,r) : functionAttributeListIDs s } return r - Just (_, id') -> return id' + Just (_, id') -> do + liftIO (FFI.disposeAttributeSet p) + return id' diff --git a/src/LLVM/Internal/FFI/Attribute.h b/src/LLVM/Internal/FFI/Attribute.h --- a/src/LLVM/Internal/FFI/Attribute.h +++ b/src/LLVM/Internal/FFI/Attribute.h @@ -46,6 +46,7 @@ macro(SExt,T,T,F) \ macro(SafeStack,F,F,T) \ macro(SanitizeAddress,F,F,T) \ + macro(SanitizeHWAddress,F,F,T) \ macro(SanitizeMemory,F,F,T) \ macro(SanitizeThread,F,F,T) \ macro(Speculatable,F,F,T) \ @@ -53,6 +54,7 @@ macro(StackProtect,F,F,T) \ macro(StackProtectReq,F,F,T) \ macro(StackProtectStrong,F,F,T) \ + macro(StrictFP,F,F,T) \ macro(StructRet,T,F,F) \ macro(SwiftError,T,F,F) \ macro(SwiftSelf,T,F,F) \ diff --git a/src/LLVM/Internal/FFI/Instruction.h b/src/LLVM/Internal/FFI/Instruction.h --- a/src/LLVM/Internal/FFI/Instruction.h +++ b/src/LLVM/Internal/FFI/Instruction.h @@ -37,12 +37,13 @@ /* The last parameter to the macro indicates whether the set function takes a boolean argument or not */ #define LLVM_HS_FOR_EACH_FAST_MATH_FLAG(macro) \ - macro(UnsafeAlgebra, unsafeAlgebra, F) \ + macro(AllowReassoc, allowReassoc, F) \ macro(NoNaNs, noNaNs, F) \ macro(NoInfs, noInfs, F) \ macro(NoSignedZeros, noSignedZeros, F) \ macro(AllowReciprocal, allowReciprocal, F) \ - macro(AllowContract, allowContract, T) + macro(AllowContract, allowContract, T) \ + macro(ApproxFunc, approxFunc, F) typedef enum { #define ENUM_CASE(x,l,takesArg) LLVM ## x ## Bit, diff --git a/src/LLVM/Internal/FFI/OrcJIT.hs b/src/LLVM/Internal/FFI/OrcJIT.hs --- a/src/LLVM/Internal/FFI/OrcJIT.hs +++ b/src/LLVM/Internal/FFI/OrcJIT.hs @@ -35,6 +35,9 @@ FunPtr SymbolResolverFn -> IO (Ptr LambdaResolver) +foreign import ccall safe "LLVM_Hs_disposeLambdaResolver" disposeLambdaResolver :: + Ptr LambdaResolver -> IO () + foreign import ccall safe "LLVM_Hs_createObjectLinkingLayer" createObjectLinkingLayer :: IO (Ptr ObjectLinkingLayer) diff --git a/src/LLVM/Internal/FFI/OrcJITC.cpp b/src/LLVM/Internal/FFI/OrcJITC.cpp --- a/src/LLVM/Internal/FFI/OrcJITC.cpp +++ b/src/LLVM/Internal/FFI/OrcJITC.cpp @@ -291,6 +291,10 @@ createLambdaResolver(dylibResolverFun, externalResolverFun)); } +void LLVM_Hs_disposeLambdaResolver(LLVMLambdaResolverRef resolver) { + delete resolver; +} + static JITSymbolFlags unwrap(LLVMJITSymbolFlags f) { JITSymbolFlags flags = JITSymbolFlags::None; #define ENUM_CASE(x) \ diff --git a/src/LLVM/Internal/FFI/PassManagerC.cpp b/src/LLVM/Internal/FFI/PassManagerC.cpp --- a/src/LLVM/Internal/FFI/PassManagerC.cpp +++ b/src/LLVM/Internal/FFI/PassManagerC.cpp @@ -9,6 +9,7 @@ #include "llvm/Transforms/IPO/PassManagerBuilder.h" #include "llvm/Transforms/Vectorize.h" #include "llvm/Transforms/Instrumentation.h" +#include "llvm/Transforms/Instrumentation/BoundsChecking.h" #include "llvm/CodeGen/Passes.h" #include "llvm-c/Target.h" #include "llvm-c/Transforms/PassManagerBuilder.h" @@ -159,7 +160,7 @@ } void LLVM_Hs_AddBoundsCheckingPass(LLVMPassManagerRef PM) { - unwrap(PM)->add(createBoundsCheckingPass()); + unwrap(PM)->add(createBoundsCheckingLegacyPass()); } void LLVM_Hs_AddLoopVectorizePass( diff --git a/src/LLVM/Internal/FFI/RTDyldMemoryManager.hs b/src/LLVM/Internal/FFI/RTDyldMemoryManager.hs --- a/src/LLVM/Internal/FFI/RTDyldMemoryManager.hs +++ b/src/LLVM/Internal/FFI/RTDyldMemoryManager.hs @@ -5,7 +5,6 @@ import LLVM.Prelude -import Data.Word import Foreign.C.String -- | diff --git a/src/LLVM/Internal/FFI/TargetC.cpp b/src/LLVM/Internal/FFI/TargetC.cpp --- a/src/LLVM/Internal/FFI/TargetC.cpp +++ b/src/LLVM/Internal/FFI/TargetC.cpp @@ -163,11 +163,11 @@ switch (x) { #define ENUM_CASE(x) \ case LLVM_Hs_DebuggerKind_##x: \ - return DebuggerKind::x; - LLVM_HS_FOR_EACH_DEBUGGER_KIND(ENUM_CASE) + return DebuggerKind::x; + LLVM_HS_FOR_EACH_DEBUGGER_KIND(ENUM_CASE) #undef ENUM_CASE default: - return DebuggerKind(0); + return DebuggerKind(0); } } @@ -270,8 +270,8 @@ } } -void LLVM_Hs_SetMCTargetOptionFlag(MCTargetOptions *to, LLVM_Hs_MCTargetOptionFlag f, - unsigned v) { +void LLVM_Hs_SetMCTargetOptionFlag(MCTargetOptions *to, + LLVM_Hs_MCTargetOptionFlag f, unsigned v) { switch (f) { #define ENUM_CASE(op) \ case LLVM_Hs_MCTargetOptionFlag_##op: \ @@ -494,11 +494,10 @@ // None of the other components are bound yet } -LLVMTargetMachineRef -LLVM_Hs_CreateTargetMachine(LLVMTargetRef T, const char *Triple, - const char *CPU, const char *Features, - TargetOptions *TO, LLVMRelocMode Reloc, - LLVMCodeModel CodeModel, LLVMCodeGenOptLevel Level) { +LLVMTargetMachineRef LLVM_Hs_CreateTargetMachine( + LLVMTargetRef T, const char *Triple, const char *CPU, const char *Features, + TargetOptions *TO, LLVMRelocMode Reloc, LLVMCodeModel CodeModel, + LLVMCodeGenOptLevel Level) { Optional RM; switch (Reloc) { case LLVMRelocStatic: @@ -514,7 +513,8 @@ break; } - CodeModel::Model CM = unwrap(CodeModel); + bool JIT; + Optional CM = unwrap(CodeModel, JIT); CodeGenOpt::Level OL; switch (Level) { @@ -532,8 +532,8 @@ break; } - return wrap( - unwrap(T)->createTargetMachine(Triple, CPU, Features, *TO, RM, CM, OL)); + return wrap(unwrap(T)->createTargetMachine(Triple, CPU, Features, *TO, RM, + CM, OL, JIT)); } TargetOptions *LLVM_Hs_TargetMachineOptions(LLVMTargetMachineRef TM) { diff --git a/src/LLVM/Internal/FastMathFlags.hs b/src/LLVM/Internal/FastMathFlags.hs --- a/src/LLVM/Internal/FastMathFlags.hs +++ b/src/LLVM/Internal/FastMathFlags.hs @@ -21,15 +21,16 @@ import qualified LLVM.AST as A instance EncodeM IO A.FastMathFlags FFI.FastMathFlags where - encodeM A.NoFastMathFlags = return 0 - encodeM A.UnsafeAlgebra = return FFI.fastMathFlagsUnsafeAlgebra - encodeM f = return $ foldr1 (.|.) [ + encodeM f = return $ foldr1 (.|.) [ if a f then b else 0 | (a,b) <- [ + (A.allowReassoc, FFI.fastMathFlagsAllowReassoc), (A.noNaNs, FFI.fastMathFlagsNoNaNs), (A.noInfs, FFI.fastMathFlagsNoInfs), (A.noSignedZeros, FFI.fastMathFlagsNoSignedZeros), - (A.allowReciprocal, FFI.fastMathFlagsAllowReciprocal) + (A.allowReciprocal, FFI.fastMathFlagsAllowReciprocal), + (A.allowContract, FFI.fastMathFlagsAllowContract), + (A.approxFunc, FFI.fastMathFlagsApproxFunc) ] ] @@ -40,12 +41,13 @@ anyContToM $ bracket (FFI.setFastMathFlags builder f) (\() -> FFI.setFastMathFlags builder 0) instance Monad m => DecodeM m A.FastMathFlags FFI.FastMathFlags where - decodeM 0 = return A.NoFastMathFlags - decodeM f | FFI.fastMathFlagsUnsafeAlgebra .&. f /= 0 = return A.UnsafeAlgebra decodeM f = return A.FastMathFlags { + A.allowReassoc = FFI.fastMathFlagsAllowReassoc .&. f /= 0, A.noNaNs = FFI.fastMathFlagsNoNaNs .&. f /= 0, A.noInfs = FFI.fastMathFlagsNoInfs .&. f /= 0, A.noSignedZeros = FFI.fastMathFlagsNoSignedZeros .&. f /= 0, - A.allowReciprocal = FFI.fastMathFlagsAllowReciprocal .&. f /= 0 + A.allowReciprocal = FFI.fastMathFlagsAllowReciprocal .&. f /= 0, + A.allowContract = FFI.fastMathFlagsAllowContract .&. f /= 0, + A.approxFunc = FFI.fastMathFlagsApproxFunc .&. f /= 0 } diff --git a/src/LLVM/Internal/OrcJIT.hs b/src/LLVM/Internal/OrcJIT.hs --- a/src/LLVM/Internal/OrcJIT.hs +++ b/src/LLVM/Internal/OrcJIT.hs @@ -7,7 +7,7 @@ import Control.Monad.AnyCont import Control.Monad.IO.Class import Data.Bits -import Data.ByteString (ByteString, packCString, useAsCString) +import Data.ByteString (packCString, useAsCString) import Data.IORef import Foreign.C.String import Foreign.Ptr @@ -108,7 +108,7 @@ encodeM (SymbolResolver dylib external) = return $ \cleanups -> do dylib' <- allocFunPtr cleanups (encodeM dylib) external' <- allocFunPtr cleanups (encodeM external) - FFI.createLambdaResolver dylib' external' + allocWithCleanup cleanups (FFI.createLambdaResolver dylib' external') FFI.disposeLambdaResolver instance MonadIO m => EncodeM m SymbolResolverFn (FunPtr FFI.SymbolResolverFn) where encodeM callback = @@ -117,12 +117,16 @@ setSymbol <- encodeM =<< callback =<< decodeM symbol setSymbol result) --- | allocate a function pointer and register it for cleanup +-- | Allocate the resource and register it for cleanup. +allocWithCleanup :: IORef [IO ()] -> IO a -> (a -> IO ()) -> IO a +allocWithCleanup cleanups alloc free = mask $ \restore -> do + a <- restore alloc + modifyIORef cleanups (free a :) + pure a + +-- | allocate a function pointer and register it for cleanup. allocFunPtr :: IORef [IO ()] -> IO (FunPtr a) -> IO (FunPtr a) -allocFunPtr cleanups alloc = mask $ \restore -> do - funPtr <- restore alloc - modifyIORef cleanups (freeHaskellFunPtr funPtr :) - pure funPtr +allocFunPtr cleanups alloc = allocWithCleanup cleanups alloc freeHaskellFunPtr -- | Dispose of a 'LinkingLayer'. disposeLinkingLayer :: LinkingLayer l => l -> IO () diff --git a/src/LLVM/Internal/String.hs b/src/LLVM/Internal/String.hs --- a/src/LLVM/Internal/String.hs +++ b/src/LLVM/Internal/String.hs @@ -10,7 +10,6 @@ import Control.Monad.AnyCont import Control.Monad.IO.Class import Control.Exception (finally) -import Data.Maybe (fromMaybe) import Foreign.C (CString, CChar) import Foreign.Ptr import Foreign.Storable (Storable) diff --git a/test/LLVM/Test/FunctionAttribute.hs b/test/LLVM/Test/FunctionAttribute.hs --- a/test/LLVM/Test/FunctionAttribute.hs +++ b/test/LLVM/Test/FunctionAttribute.hs @@ -39,6 +39,7 @@ , return StackProtect , return StackProtectReq , return StackProtectStrong + , return StrictFP , return NoRedZone , return NoImplicitFloat , return Naked @@ -53,6 +54,7 @@ , return JumpTable , return NoDuplicate , return SanitizeAddress + , return SanitizeHWAddress , return SanitizeThread , return SanitizeMemory , StringAttribute <$> (B.pack <$> arbitrary) <*> (B.pack <$> arbitrary) diff --git a/test/LLVM/Test/Instructions.hs b/test/LLVM/Test/Instructions.hs --- a/test/LLVM/Test/Instructions.hs +++ b/test/LLVM/Test/Instructions.hs @@ -4,6 +4,7 @@ import Test.Tasty import Test.Tasty.HUnit +import Test.Tasty.QuickCheck (Arbitrary(..), (===), ioProperty, oneof, testProperty) import LLVM.Test.Support @@ -34,6 +35,9 @@ import qualified LLVM.AST.Constant as C import qualified LLVM.AST.RMWOperation as RMWOp +import LLVM.Internal.Coding (decodeM, encodeM) +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI + tests = testGroup "Instructions" [ testGroup "regular" [ testCase name $ do @@ -102,7 +106,7 @@ "add nuw i32 %0, %0"), ("fadd", FAdd { - fastMathFlags = NoFastMathFlags, + fastMathFlags = noFastMathFlags, operand0 = a 1, operand1 = a 1, metadata = [] @@ -119,7 +123,7 @@ "sub i32 %0, %0"), ("fsub", FSub { - fastMathFlags = NoFastMathFlags, + fastMathFlags = noFastMathFlags, operand0 = a 1, operand1 = a 1, metadata = [] @@ -136,7 +140,7 @@ "mul i32 %0, %0"), ("fmul", FMul { - fastMathFlags = NoFastMathFlags, + fastMathFlags = noFastMathFlags, operand0 = a 1, operand1 = a 1, metadata = [] @@ -168,7 +172,7 @@ "sdiv i32 %0, %0"), ("fdiv", FDiv { - fastMathFlags = NoFastMathFlags, + fastMathFlags = noFastMathFlags, operand0 = a 1, operand1 = a 1, metadata = [] @@ -190,7 +194,7 @@ "srem i32 %0, %0"), ("frem", FRem { - fastMathFlags = NoFastMathFlags, + fastMathFlags = noFastMathFlags, operand0 = a 1, operand1 = a 1, metadata = [] @@ -198,7 +202,15 @@ "frem float %1, %1"), ("frem fast", FRem { - fastMathFlags = UnsafeAlgebra, + fastMathFlags = FastMathFlags { + allowReassoc = True, + noNaNs = True, + noInfs = True, + noSignedZeros = True, + allowReciprocal = True, + allowContract = True, + approxFunc = True + }, operand0 = a 1, operand1 = a 1, metadata = [] @@ -501,7 +513,7 @@ [Catch (C.Null (ptr i8))], "\n catch i8* null"), ("filter", - [Filter (C.Null (ArrayType 1 (ptr i8)))], + [Filter (C.AggregateZero (ArrayType 1 (ptr i8)))], "\n filter [1 x i8*] zeroinitializer") ], (cpn, cp, cps) <- [ ("-cleanup", True, "\n cleanup"), ("", False, "") ], @@ -1236,5 +1248,26 @@ \}\n" ) ] - ] + ], + + testGroup "fast-math flags" [ + testProperty "roundtrip" $ \flags -> + ioProperty $ withContext $ \ctx -> do + encodedFlags <- encodeM flags :: IO FFI.FastMathFlags + decodedFlags <- decodeM encodedFlags :: IO FastMathFlags + pure (decodedFlags === flags) + ] ] + +instance Arbitrary FastMathFlags where + arbitrary = oneof + [ pure noFastMathFlags + , FastMathFlags <$> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary + ] diff --git a/test/LLVM/Test/Optimization.hs b/test/LLVM/Test/Optimization.hs --- a/test/LLVM/Test/Optimization.hs +++ b/test/LLVM/Test/Optimization.hs @@ -177,7 +177,7 @@ testCase "SLPVectorization" $ do let fadd op0 op1 = - FAdd { fastMathFlags = NoFastMathFlags, operand0 = op0, operand1 = op1, metadata = [] } + FAdd { fastMathFlags = noFastMathFlags, operand0 = op0, operand1 = op1, metadata = [] } doubleVec = VectorType 2 double constInt i = ConstantOperand (C.Int {C.integerBits = 32, C.integerValue = i}) undef = ConstantOperand (C.Undef doubleVec) @@ -246,7 +246,7 @@ G.name = Name "a", G.linkage = L.Common, G.type' = A.T.ArrayType 2048 i32, - G.initializer = Just (C.Null (A.T.ArrayType 2048 i32)) + G.initializer = Just (C.AggregateZero (A.T.ArrayType 2048 i32)) }, GlobalDefinition $ functionDefaults { G.returnType = A.T.void, diff --git a/test/LLVM/Test/OrcJIT.hs b/test/LLVM/Test/OrcJIT.hs --- a/test/LLVM/Test/OrcJIT.hs +++ b/test/LLVM/Test/OrcJIT.hs @@ -102,7 +102,7 @@ JITSymbol mainFn _ <- findSymbol compileLayer mainSymbol True result <- mkMain (castPtrToFunPtr (wordPtrToPtr mainFn)) result @?= 42 - assert (readIORef passmanagerSuccessful), + readIORef passmanagerSuccessful @? "passmanager failed", testCase "lazy compilation" $ do withTestModule $ \mod -> diff --git a/test/LLVM/Test/Regression.hs b/test/LLVM/Test/Regression.hs --- a/test/LLVM/Test/Regression.hs +++ b/test/LLVM/Test/Regression.hs @@ -8,7 +8,7 @@ import qualified LLVM.AST as AST import LLVM.AST hiding (Module) -import LLVM.AST.Constant +import qualified LLVM.AST.Constant as C import LLVM.AST.Global import LLVM.AST.Type @@ -34,7 +34,7 @@ Store False (LocalReference (ptr i32) (UnName 0)) - (ConstantOperand (Int 32 42)) + (ConstantOperand (C.Int 32 42)) Nothing 0 [] @@ -65,7 +65,7 @@ (ptr $ ptr $ FunctionType void [] False) (UnName 0)) (ConstantOperand $ - GlobalReference (FunctionType void [] False) "test") + C.GlobalReference (FunctionType void [] False) "test") Nothing 0 [] @@ -76,6 +76,30 @@ ] } +example3 :: AST.Module +example3 = + defaultModule + { moduleDefinitions = + [ GlobalDefinition + functionDefaults + { name = "test" + , returnType = void + , basicBlocks = + [ BasicBlock + "entry" + [ UnName 0 := GetElementPtr { + inBounds = False, + address = ConstantOperand (C.Null i32), + indices = [ ConstantOperand (C.Int 32 0) ], + metadata = [] + } + ] + (Do $ Ret Nothing []) + ] + } + ] + } + shouldThrowEncodeException :: AST.Module -> String -> IO () shouldThrowEncodeException ast errMsg = do result <- try $ withContext $ \context -> do @@ -95,5 +119,9 @@ , testCase "no implicit casts" (example2 `shouldThrowEncodeException` - "The serialized GlobalReference has type PointerType {pointerReferent = FunctionType {resultType = VoidType, argumentTypes = [], isVarArg = False}, pointerAddrSpace = AddrSpace 0} but should have type FunctionType {resultType = VoidType, argumentTypes = [], isVarArg = False}") + "The serialized GlobalReference Name \"test\" has type FunctionType {resultType = VoidType, argumentTypes = [], isVarArg = False} but should have type PointerType {pointerReferent = FunctionType {resultType = VoidType, argumentTypes = [], isVarArg = False}, pointerAddrSpace = AddrSpace 0}") + , testCase + "null constants must have pointer type" + (example3 `shouldThrowEncodeException` + "Null pointer constant must have pointer type but has type IntegerType {typeBits = 32}.") ]