llvm-hs 5.1.3 → 6.0.0

raw patch · 21 files changed

+222/−83 lines, 21 filesdep ~basedep ~llvm-hs-puredep ~temporarysetup-changedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, llvm-hs-pure, temporary

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• Setup.hs +14/−7
• llvm-hs.cabal +4/−4
• src/LLVM/Internal/Attribute.hs +4/−0
• src/LLVM/Internal/Constant.hs +63/−24
• src/LLVM/Internal/DecodeAST.hs +3/−1
• src/LLVM/Internal/FFI/Attribute.h +2/−0
• src/LLVM/Internal/FFI/Instruction.h +3/−2
• src/LLVM/Internal/FFI/OrcJIT.hs +3/−0
• src/LLVM/Internal/FFI/OrcJITC.cpp +4/−0
• src/LLVM/Internal/FFI/PassManagerC.cpp +2/−1
• src/LLVM/Internal/FFI/RTDyldMemoryManager.hs +0/−1
• src/LLVM/Internal/FFI/TargetC.cpp +13/−13
• src/LLVM/Internal/FastMathFlags.hs +9/−7
• src/LLVM/Internal/OrcJIT.hs +11/−7
• src/LLVM/Internal/String.hs +0/−1
• test/LLVM/Test/FunctionAttribute.hs +2/−0
• test/LLVM/Test/Instructions.hs +41/−8
• test/LLVM/Test/Optimization.hs +2/−2
• test/LLVM/Test/OrcJIT.hs +1/−1
• test/LLVM/Test/Regression.hs +32/−4

@@ -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`.

@@ -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]

@@ -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 <moritz.kiefer@purelyfunctional.org>, 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

@@ -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

@@ -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  -  -  ++

@@ -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'

@@ -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)                            \

@@ -37,12 +37,13 @@  /* The last parameter to the macro indicates whether the set<param> 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,

@@ -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) 

@@ -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)                                                           \

@@ -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(

@@ -5,7 +5,6 @@  import LLVM.Prelude -import Data.Word import Foreign.C.String  -- | <https://llvm.org/doxygen/classllvm_1_1RTDyldMemoryManager.html#a5fee247bdc0c5af393b66bfd73a0a347>

@@ -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<Reloc::Model> RM;     switch (Reloc) {     case LLVMRelocStatic:@@ -514,7 +513,8 @@         break;     } -    CodeModel::Model CM = unwrap(CodeModel);+    bool JIT;+    Optional<CodeModel::Model> 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) {

@@ -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               } 

@@ -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 ()

@@ -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)

@@ -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)

@@ -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+    ]

@@ -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,

@@ -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 ->

@@ -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}.")     ]