llvm-hs 4.2.0 → 5.0.0

raw patch · 64 files changed

+980/−782 lines, 64 filesdep ~llvm-hs-puresetup-changedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: llvm-hs-pure

API changes (from Hackage documentation)

Files

• CHANGELOG.md +27/−0
• Setup.hs +5/−7
• llvm-hs.cabal +7/−5
• src/LLVM/Internal/Atomicity.hs +1/−1
• src/LLVM/Internal/Attribute.hs +75/−57
• src/LLVM/Internal/CallingConvention.hs +5/−3
• src/LLVM/Internal/Coding.hs +2/−2
• src/LLVM/Internal/Constant.hs +97/−72
• src/LLVM/Internal/DecodeAST.hs +16/−9
• src/LLVM/Internal/EncodeAST.hs +4/−0
• src/LLVM/Internal/ExecutionEngine.hs +1/−0
• src/LLVM/Internal/FFI/Attribute.h +1/−0
• src/LLVM/Internal/FFI/Attribute.hs +49/−33
• src/LLVM/Internal/FFI/AttributeC.cpp +86/−69
• src/LLVM/Internal/FFI/AttributeC.hpp +3/−16
• src/LLVM/Internal/FFI/Builder.hs +1/−0
• src/LLVM/Internal/FFI/BuilderC.cpp +10/−8
• src/LLVM/Internal/FFI/CallingConvention.h +1/−1
• src/LLVM/Internal/FFI/Cleanup.hs +4/−2
• src/LLVM/Internal/FFI/Constant.hs +5/−1
• src/LLVM/Internal/FFI/ErrorHandling.cpp +8/−0
• src/LLVM/Internal/FFI/ErrorHandling.hpp +7/−0
• src/LLVM/Internal/FFI/Function.hs +4/−4
• src/LLVM/Internal/FFI/FunctionC.cpp +15/−14
• src/LLVM/Internal/FFI/Instruction.h +10/−8
• src/LLVM/Internal/FFI/Instruction.hs +11/−6
• src/LLVM/Internal/FFI/InstructionC.cpp +16/−23
• src/LLVM/Internal/FFI/InstructionDefs.hsc +1/−1
• src/LLVM/Internal/FFI/LLVMCTypes.hsc +8/−1
• src/LLVM/Internal/FFI/Metadata.hpp +0/−11
• src/LLVM/Internal/FFI/MetadataC.cpp +0/−1
• src/LLVM/Internal/FFI/OrcJIT.hs +1/−1
• src/LLVM/Internal/FFI/OrcJIT/CompileLayer.hs +9/−9
• src/LLVM/Internal/FFI/OrcJITC.cpp +104/−154
• src/LLVM/Internal/FFI/PassManager.hs +1/−1
• src/LLVM/Internal/FFI/PassManagerC.cpp +2/−54
• src/LLVM/Internal/FFI/Target.h +11/−2
• src/LLVM/Internal/FFI/Target.hs +6/−0
• src/LLVM/Internal/FFI/TargetC.cpp +42/−6
• src/LLVM/Internal/FFI/Type.hs +4/−0
• src/LLVM/Internal/Function.hs +14/−16
• src/LLVM/Internal/Instruction.hs +63/−28
• src/LLVM/Internal/LibraryFunction.hsc +1/−0
• src/LLVM/Internal/Module.hs +3/−3
• src/LLVM/Internal/OrcJIT.hs +4/−2
• src/LLVM/Internal/OrcJIT/CompileLayer.hs +27/−29
• src/LLVM/Internal/PassManager.hs +2/−1
• src/LLVM/Internal/Target.hs +9/−8
• src/LLVM/Internal/Type.hs +1/−0
• src/LLVM/Internal/Value.hs +0/−1
• src/LLVM/OrcJIT.hs +4/−4
• src/LLVM/Target/Options.hs +8/−2
• src/LLVM/Transforms.hs +0/−54
• test/LLVM/Test/CallingConvention.hs +1/−1
• test/LLVM/Test/FunctionAttribute.hs +7/−4
• test/LLVM/Test/Instructions.hs +5/−5
• test/LLVM/Test/Instrumentation.hs +7/−1
• test/LLVM/Test/Module.hs +1/−1
• test/LLVM/Test/Optimization.hs +45/−20
• test/LLVM/Test/OrcJIT.hs +10/−10
• test/LLVM/Test/Regression.hs +99/−0
• test/LLVM/Test/Target.hs +4/−2
• test/LLVM/Test/Tests.hs +3/−1
• test/Test.hs +2/−7

@@ -1,3 +1,30 @@+## 5.0.0 (2017-09-07)++* Support for LLVM 5.0++    We only give a summary of the changes affecting the public API of `llvm-hs` here.+    Please refer to the official+    [release notes for LLVM 5.0](http://releases.llvm.org/5.0.0/docs/ReleaseNotes.html)+    for an overview of all changes in LLVM 5.0.++    * The `X86_64_Win64` calling convention is now called `Win64`.+    * There is a new `Speculatable` function attribute.+    * The `CrossThread` synchronization scope has been removed. There is+      now a new `System` synchronization scope.+    * The `OrcJIT`-API now operates on individual modules instead of+      sets of modules.+    * The `lessPreciseFloatingPointMultiplyAddOption` field has been+      removed from the target options.+    * The `compressDebugSections` option field is now of type+      `DebugCompressionType` instead of `Bool`.+    * The `BasicBlockVectorize` pass has been removed. You should use+      `SuperwordLevelParallelismVectorize` instead.++* Throw 'EncodeException' when the type supplied in a+  'GlobalReference' does not match the type of the expression.+* Throw 'EncodeException' when the result of instructions returning+  void is named using ':='.+ ## 4.2.0 (2017-06-20)  * Revamp OrcJIT API

@@ -35,7 +35,7 @@ mkFlagName = FlagName #endif -llvmVersion = mkVersion [4,0]+llvmVersion = mkVersion [5,0]  llvmConfigNames = [   "llvm-config-" ++ (intercalate "." . map show . versionNumbers $ llvmVersion),@@ -79,13 +79,11 @@ llvmProgram :: Program llvmProgram = (simpleProgram "llvm-config") {   programFindLocation = programSearch (programFindLocation . simpleProgram),-  programFindVersion =+  programFindVersion = \verbosity path ->     let-      stripSuffix suf str = let r = reverse in liftM r (stripPrefix (r suf) (r str))-      svnToTag v = maybe v (++"-svn") (stripSuffix "svn" v)+      stripVcsSuffix = takeWhile (\c -> isDigit c || c == '.')       trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse-    in-      \v p -> findProgramVersion "--version" (svnToTag . trim) v p+    in findProgramVersion "--version" (stripVcsSuffix . trim) verbosity path  }  getLLVMConfig :: ConfigFlags -> IO ([String] -> IO String)@@ -164,7 +162,7 @@                     libBuildInfo =                       mempty {                         ccOptions = llvmCxxFlags,-                        extraLibs = stdLib : libs ++ systemLibs+                        extraLibs = libs ++ stdLib : systemLibs                       }                   }               }

@@ -1,5 +1,5 @@ name: llvm-hs-version: 4.2.0+version: 5.0.0 license: BSD3 license-file: LICENSE author: Anthony Cowley, Stephen Diehl, Moritz Kiefer <moritz.kiefer@purelyfunctional.org>, Benjamin S. Scarlet@@ -24,11 +24,11 @@   src/LLVM/Internal/FFI/BinaryOperator.h   src/LLVM/Internal/FFI/CallingConvention.h   src/LLVM/Internal/FFI/Constant.h+  src/LLVM/Internal/FFI/ErrorHandling.hpp   src/LLVM/Internal/FFI/GlobalValue.h   src/LLVM/Internal/FFI/InlineAssembly.h   src/LLVM/Internal/FFI/Instruction.h   src/LLVM/Internal/FFI/LibFunc.h-  src/LLVM/Internal/FFI/Metadata.hpp   src/LLVM/Internal/FFI/OrcJIT.h   src/LLVM/Internal/FFI/SMDiagnostic.h   src/LLVM/Internal/FFI/Target.h@@ -62,7 +62,7 @@  library   build-tools: llvm-config-  ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans -fno-warn-incomplete-patterns -fno-warn-missing-signatures -fno-warn-unused-matches+  ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans   if flag(semigroups)     build-depends:       base >= 4.7 && < 4.9,@@ -81,7 +81,7 @@     template-haskell >= 2.5.0.0,     containers >= 0.4.2.1,     array >= 0.4.0.0,-    llvm-hs-pure == 4.1.0.0+    llvm-hs-pure == 5.0.0   hs-source-dirs: src   extensions:     NoImplicitPrelude@@ -210,6 +210,7 @@     src/LLVM/Internal/FFI/CallingConventionC.cpp     src/LLVM/Internal/FFI/ConstantC.cpp     src/LLVM/Internal/FFI/CommandLineC.cpp+    src/LLVM/Internal/FFI/ErrorHandling.cpp     src/LLVM/Internal/FFI/ExecutionEngineC.cpp     src/LLVM/Internal/FFI/FunctionC.cpp     src/LLVM/Internal/FFI/GlobalAliasC.cpp@@ -245,7 +246,7 @@     tasty-quickcheck >= 0.8,     QuickCheck >= 2.5.1.1,     llvm-hs,-    llvm-hs-pure == 4.1.0.0,+    llvm-hs-pure == 5.0.0,     containers >= 0.4.2.1,     mtl >= 2.1,     transformers >= 0.3.0.0,@@ -275,6 +276,7 @@     LLVM.Test.ObjectCode     LLVM.Test.OrcJIT     LLVM.Test.Optimization+    LLVM.Test.Regression     LLVM.Test.Support     LLVM.Test.Target     LLVM.Test.Tests

@@ -25,7 +25,7 @@  genCodingInstance [t| A.SynchronizationScope |] ''FFI.SynchronizationScope [   (FFI.synchronizationScopeSingleThread, A.SingleThread),-  (FFI.synchronizationScopeCrossThread, A.CrossThread)+  (FFI.synchronizationScopeSystem, A.System)  ]  instance Monad m => EncodeM m (Maybe A.Atomicity) (FFI.SynchronizationScope, FFI.MemoryOrdering) where

@@ -1,10 +1,18 @@ {-# LANGUAGE+  CPP,   MultiParamTypeClasses,   ConstraintKinds,   QuasiQuotes,+  ScopedTypeVariables,   UndecidableInstances,   RankNTypes   #-}+#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE OverlappingInstances #-}+#define CPP_OVERLAPPING+#else+#define CPP_OVERLAPPING {-# OVERLAPPING #-}+#endif module LLVM.Internal.Attribute where  import LLVM.Prelude@@ -13,11 +21,9 @@ import Control.Monad.IO.Class import Control.Monad.State (gets) +import Control.Exception import Foreign.C (CUInt) import Foreign.Ptr-import Data.Either-import Data.Map (Map)-import qualified Data.Map as Map import Data.Maybe  import qualified LLVM.Internal.FFI.Attribute as FFI@@ -108,6 +114,7 @@       A.FA.SanitizeThread -> FFI.functionAttributeKindSanitizeThread       A.FA.SanitizeMemory -> FFI.functionAttributeKindSanitizeMemory       A.FA.SafeStack -> FFI.functionAttributeKindSafeStack+      A.FA.Speculatable -> FFI.functionAttributeKindSpeculatable       A.FA.StackAlignment _ -> inconsistentCases "FunctionAttribute" a       A.FA.AllocSize _ _ -> inconsistentCases "FunctionAttribute" a       A.FA.StringAttribute _ _ -> inconsistentCases "FunctionAttribute" a@@ -191,6 +198,7 @@            [functionAttributeKindP|InaccessibleMemOrArgMemOnly|] -> return A.FA.InaccessibleMemOrArgMemOnly            [functionAttributeKindP|SafeStack|] -> return A.FA.SafeStack            [functionAttributeKindP|WriteOnly|] -> return A.FA.WriteOnly+           [functionAttributeKindP|Speculatable|] -> return A.FA.Speculatable            _ -> error $ "unhandled function attribute enum value: " ++ show enum  allocaAttrBuilder :: (Monad m, MonadAnyCont IO m) => m (Ptr (FFI.AttrBuilder a))@@ -202,28 +210,27 @@     FFI.destroyAttrBuilder ab     return r -instance EncodeM EncodeAST a (Ptr (FFI.AttrBuilder b) -> EncodeAST ()) => EncodeM EncodeAST (FFI.Index, [a]) (FFI.AttributeSet b) where-  encodeM (index, as) = scopeAnyCont $ do+instance forall a b. EncodeM EncodeAST a (Ptr (FFI.AttrBuilder b) -> EncodeAST ()) =>+         EncodeM EncodeAST [a] (FFI.AttributeSet b) where+  encodeM as = do     ab <- allocaAttrBuilder     builds <- mapM encodeM as     void (forM builds ($ ab) :: EncodeAST [()])     Context context <- gets encodeStateContext-    liftIO $ FFI.getAttributeSet context index ab--instance EncodeM EncodeAST [A.FA.FunctionAttribute] FFI.FunctionAttributeSet where-  encodeM fas = encodeM (FFI.functionIndex, fas)+    anyContToM+      (bracket (FFI.getAttributeSet context ab) FFI.disposeAttributeSet) -instance DecodeM DecodeAST a (FFI.Attribute b) => DecodeM DecodeAST [a] (FFI.AttributeSet b) where+instance forall a b. DecodeM DecodeAST a (FFI.Attribute b) => DecodeM DecodeAST [a] (FFI.AttributeSet b) where   decodeM as = do-    np <- alloca-    as <- liftIO $ FFI.attributeSetGetAttributes as 0 np-    n <- peek np-    decodeM (n, as)+    numAttributes <- liftIO (FFI.getNumAttributes as)+    attrs <- allocaArray numAttributes+    liftIO (FFI.getAttributes as attrs)+    decodeM (numAttributes, attrs :: Ptr (FFI.Attribute b))             -data MixedAttributeSet = MixedAttributeSet {+data AttributeList = AttributeList {     functionAttributes :: [Either A.FA.GroupID A.FA.FunctionAttribute],     returnAttributes :: [A.PA.ParameterAttribute],-    parameterAttributes :: Map CUInt [A.PA.ParameterAttribute]+    parameterAttributes :: [[A.PA.ParameterAttribute]]   }   deriving (Eq, Show) @@ -233,47 +240,58 @@   | ReturnAttributes [A.PA.ParameterAttribute]   | ParameterAttributes CUInt [A.PA.ParameterAttribute]     -instance EncodeM EncodeAST PreSlot FFI.MixedAttributeSet where-  encodeM preSlot = do-    let forget = liftM FFI.forgetAttributeType-    case preSlot of-      IndirectFunctionAttributes gid -> forget (referAttributeGroup gid)-      DirectFunctionAttributes fas -> forget (encodeM fas :: EncodeAST FFI.FunctionAttributeSet)-      ReturnAttributes as -> forget (encodeM (FFI.returnIndex, as) :: EncodeAST FFI.ParameterAttributeSet)-      ParameterAttributes i as -> forget (encodeM (fromIntegral (i + 1) :: FFI.Index, as) :: EncodeAST FFI.ParameterAttributeSet)--instance EncodeM EncodeAST MixedAttributeSet FFI.MixedAttributeSet where-  encodeM (MixedAttributeSet fAttrs rAttrs pAttrs) = do-    let directP = DirectFunctionAttributes (rights fAttrs)-        indirectPs = map IndirectFunctionAttributes (lefts fAttrs)-        returnP = ReturnAttributes rAttrs-        paramPs = [ ParameterAttributes x as | (x, as) <- Map.toList pAttrs ]-    (nAttrs, attrs) <- encodeM ([directP, returnP] ++ indirectPs ++ paramPs)+instance CPP_OVERLAPPING EncodeM EncodeAST [Either A.FA.GroupID A.FA.FunctionAttribute] FFI.FunctionAttributeSet where+  encodeM attrs = do+    ab <- allocaAttrBuilder+    forM_ attrs $ \attr ->+      case attr of+        Left groupId -> do+          attrSet <- referAttributeGroup groupId+          ab' <- anyContToM (bracket (FFI.attrBuilderFromSet attrSet) FFI.disposeAttrBuilder)+          liftIO (FFI.mergeAttrBuilder ab ab')+        Right attr -> do+          addAttr <- encodeM attr+          addAttr ab :: EncodeAST ()     Context context <- gets encodeStateContext-    liftIO $ FFI.mixAttributeSets context attrs nAttrs+    anyContToM+      (bracket (FFI.getAttributeSet context ab) FFI.disposeAttributeSet) -instance DecodeM DecodeAST MixedAttributeSet FFI.MixedAttributeSet where-  decodeM mas = do-    numSlots <- if mas == nullPtr then return 0 else liftIO $ FFI.attributeSetNumSlots mas-    slotIndexes <- forM (take (fromIntegral numSlots) [0..]) $ \s -> do-      i <- liftIO $ FFI.attributeSetSlotIndex mas s-      return (i, s)-    let separate :: Ord k => k -> Map k a -> (Maybe a, Map k a)-        separate = Map.updateLookupWithKey (\_ _ -> Nothing)-        indexedSlots = Map.fromList slotIndexes-    unless (Map.size indexedSlots == length slotIndexes) $-           fail "unexpected slot index collision decoding mixed AttributeSet"-    let (functionSlot, otherSlots) = separate FFI.functionIndex (Map.fromList slotIndexes)-    functionAnnotation <- for (maybeToList functionSlot) $ \slot -> do-      a <- liftIO $ FFI.attributeSetSlotAttributes mas slot-      getAttributeGroupID a-    otherAttributeSets <- for otherSlots $ \slot -> do-      a <- liftIO $ FFI.attributeSetSlotAttributes mas slot-      decodeM (a :: FFI.ParameterAttributeSet)-    let (returnAttributeSet, shiftedParameterAttributeSets) = separate FFI.returnIndex otherAttributeSets-    return $ MixedAttributeSet {-                  functionAttributes = fmap Left functionAnnotation,-                  returnAttributes = join . maybeToList $ returnAttributeSet,-                  parameterAttributes = Map.mapKeysMonotonic (\x -> fromIntegral x - 1) shiftedParameterAttributeSets-                }+instance EncodeM EncodeAST AttributeList FFI.AttributeList where+  encodeM (AttributeList fAttrs rAttrs pAttrs) = do+    fAttrSet <- encodeM fAttrs+    rAttrSet <- encodeM rAttrs :: EncodeAST FFI.ParameterAttributeSet+    (numPAttrs, pAttrSets) <- encodeM pAttrs+    Context context <- gets encodeStateContext+    anyContToM+      (bracket+         (FFI.buildAttributeList context fAttrSet rAttrSet pAttrSets numPAttrs)+         FFI.disposeAttributeList) +instance DecodeM DecodeAST AttributeList (FFI.AttrSetDecoder a, a) where+  decodeM (FFI.AttrSetDecoder attrsAtIndex countParams, a) = do+    functionAttrSet <-+      do attrSet <-+           withAttrsAtIndex FFI.functionIndex :: DecodeAST FFI.FunctionAttributeSet+         hasAttributes <-+           decodeM =<< liftIO (FFI.attributeSetHasAttributes attrSet)+         if hasAttributes+           then Just . Left <$> getAttributeGroupID attrSet+           else return Nothing+    returnAttrs <-+      do attrSet <-+           withAttrsAtIndex FFI.returnIndex :: DecodeAST FFI.ParameterAttributeSet+         decodeM attrSet+    numParams <- liftIO (countParams a)+    paramAttrs <-+      forM [1 .. numParams] $ \i ->+        decodeM =<< (withAttrsAtIndex (FFI.AttributeIndex i) :: DecodeAST FFI.ParameterAttributeSet)+    return+      (AttributeList+       { functionAttributes = maybeToList functionAttrSet+       , returnAttributes = returnAttrs+       , parameterAttributes = paramAttrs+       })+    where+      withAttrsAtIndex :: FFI.AttributeIndex -> DecodeAST (FFI.AttributeSet b)+      withAttrsAtIndex index =+        anyContToM (bracket (attrsAtIndex a index) (FFI.disposeAttributeSet))

@@ -40,7 +40,7 @@           A.CC.SPIR_KERNEL -> FFI.callingConventionSPIR_KERNEL           A.CC.Intel_OCL_BI -> FFI.callingConventionIntel_OCL_BI           A.CC.X86_64_SysV -> FFI.callingConventionX86_64_SysV-          A.CC.X86_64_Win64 -> FFI.callingConventionX86_64_Win64+          A.CC.Win64 -> FFI.callingConventionWin64           A.CC.Numbered cc' -> FFI.CallingConvention (fromIntegral cc')  instance Monad m => DecodeM m A.CC.CallingConvention FFI.CallingConvention where@@ -67,5 +67,7 @@     [callingConventionP|SPIR_KERNEL|] -> A.CC.SPIR_KERNEL     [callingConventionP|Intel_OCL_BI|] -> A.CC.Intel_OCL_BI     [callingConventionP|X86_64_SysV|] -> A.CC.X86_64_SysV-    [callingConventionP|X86_64_Win64|] -> A.CC.X86_64_Win64-    FFI.CallingConvention (CUInt ci) | ci >= 64 -> A.CC.Numbered (fromIntegral ci)+    [callingConventionP|Win64|] -> A.CC.Win64+    FFI.CallingConvention (CUInt ci)+      | ci >= 64 -> A.CC.Numbered (fromIntegral ci)+      | otherwise -> error ("Unknown calling convention: " <> show ci)

@@ -39,8 +39,8 @@      instance Monad m => DecodeM m $(ht) $(conT ctn) where       decodeM c = return $ $(-        caseE [| c |] [ match (dataToPatQ n c) (normalB (dataToExpQ n h)) [] | (c,h) <- chs ]-       )+        caseE [| c |] ([ match (dataToPatQ n c) (normalB (dataToExpQ n h)) [] | (c,h) <- chs] +++                       [ match wildP (normalB [e| error ("Decoding failed: Unknown " <> $(litE (stringL (nameBase ctn)))) |]) []]))    |]  allocaArray :: (Integral i, Storable a, MonadAnyCont IO m) => i -> m (Ptr a)

@@ -13,9 +13,10 @@ import qualified LLVM.Internal.InstructionDefs as ID  import Data.Bits-import Control.Monad.State (get, gets, modify, evalState) import Control.Monad.AnyCont+import Control.Monad.Catch import Control.Monad.IO.Class+import Control.Monad.State (get, gets, modify, evalState)  import qualified Data.Map as Map import Foreign.Ptr@@ -39,18 +40,24 @@ import qualified LLVM.AST.FloatingPointPredicate as A (FloatingPointPredicate) import qualified LLVM.AST.Float as A.F +import LLVM.Exception import LLVM.Internal.Coding+import LLVM.Internal.Context import LLVM.Internal.DecodeAST import LLVM.Internal.EncodeAST-import LLVM.Internal.Context-import LLVM.Internal.Type ()-import LLVM.Internal.IntegerPredicate () import LLVM.Internal.FloatingPointPredicate ()+import LLVM.Internal.IntegerPredicate ()+import LLVM.Internal.Type ()+import LLVM.Internal.Value  allocaWords :: forall a m . (Storable a, MonadAnyCont IO m, Monad m, MonadIO m) => Word32 -> m (Ptr a) allocaWords nBits = do   allocaArray (((nBits-1) `div` (8*(fromIntegral (sizeOf (undefined :: a))))) + 1) +inconsistentCases :: Show a => String -> a -> b+inconsistentCases name attr =+  error $ "llvm-hs internal error: cases inconstistent in " ++ name ++ " encoding for " ++ show attr+ instance EncodeM EncodeAST A.Constant (Ptr FFI.Constant) where   encodeM c = scopeAnyCont $ case c of     A.C.Int { A.C.integerBits = bits, A.C.integerValue = v } -> do@@ -89,7 +96,14 @@                     A.F.PPC_FP128 _ _ -> FFI.floatSemanticsPPCDoubleDouble       nBits <- encodeM nBits       liftIO $ FFI.constantFloatOfArbitraryPrecision context nBits words fpSem-    A.C.GlobalReference _ n -> FFI.upCast <$> referGlobal n+    A.C.GlobalReference ty n -> do+      ref <- FFI.upCast <$> referGlobal n+      ty' <- (liftIO . runDecodeAST . typeOf) ref+      if ty /= ty'+        then throwM+               (EncodeException+                  ("The serialized GlobalReference has type " ++ show ty' ++ " but should have type " ++ show ty))+        else return ref     A.C.BlockAddress f b -> do       f' <- referGlobal f       b' <- getBlockForAddress f b@@ -109,29 +123,37 @@       liftIO $ FFI.getConstTokenNone context     o -> $(do       let constExprInfo =  ID.outerJoin ID.astConstantRecs (ID.innerJoin ID.astInstructionRecs ID.instructionDefs)-      TH.caseE [| o |] $ do-        (name, (Just (TH.RecC n fs), instrInfo)) <- Map.toList constExprInfo-        let fns = [ TH.mkName . TH.nameBase $ fn | (fn, _, _) <- fs ]-            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 ]-        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.Cast -> return [| $(coreCall "Cast") $(opcode) |]-              _ -> return $ coreCall name-          Nothing -> if (name `elem` ["Vector", "Null", "Array", "Undef"])-                      then return $ coreCall name-                      else []-        return $ TH.match-          (TH.recP n [(fn,) <$> (TH.varP . TH.mkName . TH.nameBase $ fn) | (fn, _, _) <- fs])-          (TH.normalB (TH.doE (buildBody core)))-          []-      )+      TH.caseE [| o |] $+        map (\p -> TH.match p (TH.normalB [|inconsistentCases "Constant" o|]) [])+            [[p|A.C.Int{}|],+             [p|A.C.Float{}|],+             [p|A.C.Struct{}|],+             [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 ]+                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 ]+            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.Cast -> return [| $(coreCall "Cast") $(opcode) |]+                  _ -> return $ coreCall name+              Nothing ->+                if (name `elem` ["Vector", "Null", "Array", "Undef"])+                  then return $ coreCall name+                  else []+            return $ TH.match+              (TH.recP n [(fn,) <$> (TH.varP . TH.mkName . TH.nameBase $ fn) | (fn, _, _) <- fs])+              (TH.normalB (TH.doE (buildBody core)))+              [])+     )  instance DecodeM DecodeAST A.Constant (Ptr FFI.Constant) where   decodeM c = scopeAnyCont $ do@@ -147,9 +169,11 @@         op = decodeM <=< liftIO . FFI.getConstantOperand c         getConstantOperands = mapM op [0..nOps-1]          getConstantData = do-          let nElements = case t of-                            A.VectorType n _ -> n-                            A.ArrayType n _ | n <= (fromIntegral (maxBound :: Word32)) -> fromIntegral n+          let nElements =+                case t of+                  A.VectorType n _ -> n+                  A.ArrayType n _ | n <= (fromIntegral (maxBound :: Word32)) -> fromIntegral n+                  _ -> error "getConstantData can only be applied to vectors and arrays"           forM [0..nElements-1] $ do              decodeM <=< liftIO . FFI.getConstantDataSequentialElementAsConstant c . fromIntegral @@ -204,47 +228,48 @@       [valueSubclassIdP|ConstantExpr|] -> do             cppOpcode <- liftIO $ FFI.getConstantCPPOpcode c             $(-              TH.caseE [| cppOpcode |] $ do-                (name, ((TH.RecC n fs, _), iDef)) <- Map.toList $-                      ID.innerJoin (ID.innerJoin ID.astConstantRecs ID.astInstructionRecs) ID.instructionDefs-                let apWrapper o (fn, _, ct) = do-                      a <- case ct of-                             TH.ConT h-                               | h == ''A.Constant -> do-                                               operandNumber <- get-                                               modify (+1)-                                               return [| op $(TH.litE . TH.integerL $ operandNumber) |]-                               | h == ''A.Type -> return [| pure t |]-                               | h == ''A.IntegerPredicate -> -                                 return [| liftIO $ decodeM =<< FFI.getConstantICmpPredicate c |]-                               | h == ''A.FloatingPointPredicate -> -                                 return [| liftIO $ decodeM =<< FFI.getConstantFCmpPredicate c |]-                               | h == ''Bool -> case TH.nameBase fn of-                                                  "inBounds" -> return [| liftIO $ decodeM =<< FFI.getInBounds v |]-                                                  "exact" -> return [| liftIO $ decodeM =<< FFI.isExact v |]-                                                  "nsw" -> return [| liftIO $ decodeM =<< FFI.hasNoSignedWrap v |]-                                                  "nuw" -> return [| liftIO $ decodeM =<< FFI.hasNoUnsignedWrap v |]-                                                  x -> error $ "constant bool field " ++ show x ++ " not handled yet"-                             TH.AppT TH.ListT (TH.ConT h) -                               | h == ''Word32 -> -                                  return [|-                                        do-                                          np <- alloca-                                          isp <- liftIO $ FFI.getConstantIndices c np-                                          n <- peek np-                                          decodeM (n, isp)-                                        |]-                               | h == ''A.Constant -> -                                  case TH.nameBase fn of-                                    "indices" -> do-                                      operandNumber <- get-                                      return [| mapM op [$(TH.litE . TH.integerL $ operandNumber)..nOps-1] |]-                             _ -> error $ "unhandled constant expr field type: " ++ show fn ++ " - " ++ show ct-                      return [| $(o) `ap` $(a) |]-                return $ TH.match -                          (TH.dataToPatQ (const Nothing) (ID.cppOpcode iDef))-                          (TH.normalB (evalState (foldM apWrapper [| return $(TH.conE n) |] fs) 0))-                          []+              TH.caseE [| cppOpcode |] $+                (do (_, ((TH.RecC n fs, _), iDef)) <- Map.toList $+                          ID.innerJoin (ID.innerJoin ID.astConstantRecs ID.astInstructionRecs) ID.instructionDefs+                    let apWrapper o (fn, _, ct) = do+                          a <- case ct of+                                 TH.ConT h+                                   | h == ''A.Constant -> do+                                                   operandNumber <- get+                                                   modify (+1)+                                                   return [| op $(TH.litE . TH.integerL $ operandNumber) |]+                                   | h == ''A.Type -> return [| pure t |]+                                   | h == ''A.IntegerPredicate ->+                                     return [| liftIO $ decodeM =<< FFI.getConstantICmpPredicate c |]+                                   | h == ''A.FloatingPointPredicate ->+                                     return [| liftIO $ decodeM =<< FFI.getConstantFCmpPredicate c |]+                                   | h == ''Bool -> case TH.nameBase fn of+                                                      "inBounds" -> return [| liftIO $ decodeM =<< FFI.getInBounds v |]+                                                      "exact" -> return [| liftIO $ decodeM =<< FFI.isExact v |]+                                                      "nsw" -> return [| liftIO $ decodeM =<< FFI.hasNoSignedWrap v |]+                                                      "nuw" -> return [| liftIO $ decodeM =<< FFI.hasNoUnsignedWrap v |]+                                                      x -> error $ "constant bool field " ++ show x ++ " not handled yet"+                                 TH.AppT TH.ListT (TH.ConT h)+                                   | h == ''Word32 ->+                                      return [|+                                            do+                                              np <- alloca+                                              isp <- liftIO $ FFI.getConstantIndices c np+                                              n <- peek np+                                              decodeM (n, isp)+                                            |]+                                   | h == ''A.Constant &&+                                     TH.nameBase fn == "indices" -> do+                                       operandNumber <- get+                                       return [| mapM op [$(TH.litE . TH.integerL $ operandNumber)..nOps-1] |]++                                 _ -> error $ "unhandled constant expr field type: " ++ show fn ++ " - " ++ show ct+                          return [| $(o) `ap` $(a) |]+                    return $ TH.match+                              (TH.dataToPatQ (const Nothing) (ID.cppOpcode iDef))+                              (TH.normalB (evalState (foldM apWrapper [| return $(TH.conE n) |] fs) 0))+                              [])+                ++ [TH.match TH.wildP (TH.normalB [|error ("Unknown constant opcode: " <> show cppOpcode)|]) []]              )       [valueSubclassIdP|ConstantTokenNone|] -> return A.C.TokenNone       _ -> error $ "unhandled constant valueSubclassId: " ++ show valueSubclassId

@@ -46,10 +46,12 @@     metadataNodesToDefine :: Seq (A.MetadataNodeID, Ptr FFI.MDNode),     metadataNodes :: Map (Ptr FFI.MDNode) A.MetadataNodeID,     metadataKinds :: Array Word ShortByteString,-    parameterAttributeSets :: Map FFI.ParameterAttributeSet [A.A.ParameterAttribute],-    functionAttributeSetIDs :: Map FFI.FunctionAttributeSet A.A.GroupID,+    parameterAttributeLists :: Map FFI.ParameterAttributeSet [A.A.ParameterAttribute],+    functionAttributeListIDs :: [(FFI.FunctionAttributeSet, A.A.GroupID)],     comdats :: Map (Ptr FFI.COMDAT) (ShortByteString, A.COMDAT.SelectionKind)   }++initialDecode :: DecodeState initialDecode = DecodeState {     globalVarNum = Map.empty,     localVarNum = Map.empty,@@ -59,8 +61,8 @@     metadataNodesToDefine = Seq.empty,     metadataNodes = Map.empty,     metadataKinds = Array.listArray (1,0) [],-    parameterAttributeSets = Map.empty,-    functionAttributeSetIDs = Map.empty,+    parameterAttributeLists = Map.empty,+    functionAttributeListIDs = [],     comdats = Map.empty   } newtype DecodeAST a = DecodeAST { unDecodeAST :: AnyContT (StateT DecodeState IO) a }@@ -164,10 +166,15 @@  getAttributeGroupID :: FFI.FunctionAttributeSet -> DecodeAST A.A.GroupID getAttributeGroupID p = do-  ids <- gets functionAttributeSetIDs-  case Map.lookup p ids of-    Just r -> return r+  ids <- gets functionAttributeListIDs+  -- What we are interested in is the AttributeSetNode inside the+  -- AttributeSet but LLVM does not expose this. We thus have to+  -- resort to doing a linear scan and using the operator== which is+  -- implemented as a comparison on those AttributeSetNodes.+  id <- liftIO (findM (\(as, _) -> decodeM =<< FFI.attributeSetsEqual as p) ids)+  case id of     Nothing -> do-      let r = A.A.GroupID (fromIntegral (Map.size ids))-      modify $ \s -> s { functionAttributeSetIDs = Map.insert p r (functionAttributeSetIDs s) }+      let r = A.A.GroupID (fromIntegral (length ids))+      modify $ \s -> s { functionAttributeListIDs = (p,r) : functionAttributeListIDs s }       return r+    Just (_, id') -> return id'

@@ -143,9 +143,13 @@ referOrThrow :: (Show n, Ord n) => (EncodeState -> Map n v) -> String -> n -> EncodeAST v referOrThrow r m n = refer r n $ undefinedReference m n +referGlobal :: A.Name -> EncodeAST (Ptr FFI.GlobalValue) referGlobal = referOrThrow encodeStateGlobals "global"+referMDNode :: A.MetadataNodeID -> EncodeAST (Ptr FFI.MDNode) referMDNode = referOrThrow encodeStateMDNodes "metadata node"+referAttributeGroup :: A.A.GroupID -> EncodeAST FFI.FunctionAttributeSet referAttributeGroup = referOrThrow encodeStateAttributeGroups "attribute group"+referCOMDAT :: ShortByteString -> EncodeAST (Ptr FFI.COMDAT) referCOMDAT = referOrThrow encodeStateCOMDATs "COMDAT"  defineBasicBlock :: A.Name -> A.Name -> Ptr FFI.BasicBlock -> EncodeAST ()

@@ -59,6 +59,7 @@         do           p <- liftIO $ FFI.getPointerToGlobal e (FFI.upCast f)           return $ if p == nullPtr then Nothing else Just (castPtrToFunPtr p)+  getFunction _ _ = error "Only named functions can be looked up"  withExecutionEngine ::    Context ->

@@ -48,6 +48,7 @@ 	macro(SanitizeAddress,F,F,T)                      \ 	macro(SanitizeMemory,F,F,T)                       \ 	macro(SanitizeThread,F,F,T)                       \+    macro(Speculatable,F,F,T)                         \ 	macro(StackAlignment,F,F,T)                       \ 	macro(StackProtect,F,F,T)                         \ 	macro(StackProtectReq,F,F,T)                      \

@@ -1,5 +1,6 @@ {-# LANGUAGE-  ForeignFunctionInterface+  ForeignFunctionInterface,+  RankNTypes   #-} module LLVM.Internal.FFI.Attribute where @@ -11,7 +12,6 @@ import LLVM.Internal.FFI.Context import LLVM.Internal.FFI.LLVMCTypes -type Index = CInt type Slot = CUInt type IntValue = Word64 @@ -19,24 +19,14 @@ Data model: llvm::Attribute is one function or parameter attribute -llvm::AttributeSet is a mess.-It's used to represent, at different times:-a) the set of parameter attributes on a parameter-b) the set of parameter attributes for a functions return value-c) the set of function attributes for a function-d) All of the above+llvm::AttributeSet stores a set of function, return or parameter attributes -It is only possible to enumerate the attributes in an attribute set-given a "slot".+llvm::AttributeList stores the AttributeSet for the function itself,+the return value and for the functions parameters.  Encode path:-Use AttrBuilder on the C++ side only, to implement [Attribute] -> AttributeSet-AttributeSets -> whole AttributeSet--Decode strategy:-Store maps of AttributeSetImpl (Mess | Parameter | Function),-keyed by raw pointer. Expect Parameter and Function AttributeSetImpls-to have only one slot. Use the per-slot iterators to decode them+Use AttrBuilder on the C++ side only, to implement [Attribute] -> AttributeList+AttributeLists -> whole AttributeList -}  data MixedAttributeType@@ -44,24 +34,32 @@ data ParameterAttributeType data AttributeImpl a data AttributeSetImpl a+data AttributeListImpl  type Attribute a = Ptr (AttributeImpl a) type FunctionAttribute = Attribute FunctionAttributeType type ParameterAttribute = Attribute ParameterAttributeType+newtype AttributeIndex = AttributeIndex CUInt  type AttributeSet a = Ptr (AttributeSetImpl a)-type MixedAttributeSet = AttributeSet MixedAttributeType+-- type MixedAttributeSet = AttributeSet MixedAttributeType type FunctionAttributeSet = AttributeSet FunctionAttributeType type ParameterAttributeSet = AttributeSet ParameterAttributeType+type AttributeList = Ptr AttributeListImpl  forgetAttributeType :: AttributeSet a -> AttributeSet MixedAttributeType forgetAttributeType = castPtr -functionIndex :: Index-functionIndex = -1-returnIndex :: Index-returnIndex = 0+functionIndex :: AttributeIndex+functionIndex = AttributeIndex (-1)+returnIndex :: AttributeIndex+returnIndex = AttributeIndex 0 +data AttrSetDecoder a = AttrSetDecoder {+    attrSetDecoderAttributesAtIndex :: forall b. a -> AttributeIndex -> IO (AttributeSet b),+    attrSetDecoderCountParams :: a -> IO CUInt+  }+ foreign import ccall unsafe "LLVM_Hs_AttributeKindAsEnum" parameterAttributeKindAsEnum ::   ParameterAttribute -> IO ParameterAttributeKind @@ -80,30 +78,48 @@ foreign import ccall unsafe "LLVM_Hs_AttributeValueAsInt" attributeValueAsInt ::   Attribute a -> IO Word64 -foreign import ccall unsafe "LLVM_Hs_AttributeSetNumSlots" attributeSetNumSlots ::-  AttributeSet a -> IO Slot+foreign import ccall unsafe "LLVM_Hs_getNumAttributes" getNumAttributes ::+  AttributeSet a -> IO CUInt -foreign import ccall unsafe "LLVM_Hs_AttributeSetSlotIndex" attributeSetSlotIndex ::-  AttributeSet a -> Slot -> IO Index+foreign import ccall unsafe "LLVM_Hs_getAttributes" getAttributes ::+  AttributeSet a -> Ptr (Attribute a) -> IO () -foreign import ccall unsafe "LLVM_Hs_AttributeSetSlotAttributes" attributeSetSlotAttributes ::-  MixedAttributeSet -> Slot -> IO (AttributeSet a)+foreign import ccall unsafe "LLVM_Hs_GetAttributeList" getAttributeList ::+  Ptr Context -> AttributeIndex -> AttributeSet a -> IO AttributeList -foreign import ccall unsafe "LLVM_Hs_AttributeSetGetAttributes" attributeSetGetAttributes ::-  AttributeSet a -> Slot -> Ptr CUInt -> IO (Ptr (Attribute a))+foreign import ccall unsafe "LLVM_Hs_BuildAttributeList" buildAttributeList ::+  Ptr Context -> FunctionAttributeSet -> ParameterAttributeSet -> Ptr ParameterAttributeSet -> CUInt -> IO AttributeList +foreign import ccall unsafe "LLVM_Hs_DisposeAttributeList" disposeAttributeList ::+  AttributeList -> IO ()+ foreign import ccall unsafe "LLVM_Hs_GetAttributeSet" getAttributeSet ::-  Ptr Context -> Index -> Ptr (AttrBuilder a) -> IO (AttributeSet a)+  Ptr Context -> Ptr (AttrBuilder a) -> IO (AttributeSet a) -foreign import ccall unsafe "LLVM_Hs_MixAttributeSets" mixAttributeSets ::-  Ptr Context -> Ptr MixedAttributeSet -> CUInt -> IO MixedAttributeSet+foreign import ccall unsafe "LLVM_Hs_DisposeAttributeSet" disposeAttributeSet ::+  AttributeSet a -> IO () +foreign import ccall unsafe "LLVM_Hs_AttributeSetsEqual" attributeSetsEqual ::+  AttributeSet a -> AttributeSet a -> IO LLVMBool++foreign import ccall unsafe "LLVM_Hs_AttributeSetHasAttributes" attributeSetHasAttributes ::+  AttributeSet a -> IO LLVMBool+ data AttrBuilder a type FunctionAttrBuilder = AttrBuilder FunctionAttributeType type ParameterAttrBuilder = AttrBuilder ParameterAttributeType  foreign import ccall unsafe "LLVM_Hs_GetAttrBuilderSize" getAttrBuilderSize ::   CSize++foreign import ccall unsafe "LLVM_Hs_AttrBuilderFromAttrSet" attrBuilderFromSet ::+  AttributeSet a -> IO (Ptr (AttrBuilder a))++foreign import ccall unsafe "LLVM_Hs_DisposeAttrBuilder" disposeAttrBuilder ::+  Ptr (AttrBuilder a) -> IO ()++foreign import ccall unsafe "LLVM_Hs_AttrBuilderMerge" mergeAttrBuilder ::+  Ptr (AttrBuilder a) -> Ptr (AttrBuilder a) -> IO ()  foreign import ccall unsafe "LLVM_Hs_ConstructAttrBuilder" constructAttrBuilder ::   Ptr Word8 -> IO (Ptr (AttrBuilder a))

@@ -1,121 +1,137 @@ #define __STDC_LIMIT_MACROS-#include "llvm/IR/LLVMContext.h" #include "LLVM/Internal/FFI/AttributeC.hpp"+#include "llvm/IR/LLVMContext.h"  extern "C" { -static_assert(sizeof(AttributeSet) == sizeof(AttributeSetImpl *),-              "AttributeSet implementation has changed");+static_assert(sizeof(AttributeList) == sizeof(AttributeListImpl *),+              "AttributeList implementation has changed");  static_assert(sizeof(Attribute) == sizeof(AttributeImpl *),               "Attribute implementation has changed"); -unsigned LLVM_Hs_AttributeSetNumSlots(const AttributeSetImpl *a) {-	return unwrap(a).getNumSlots();+#define CHECK(name, p, r, f)                                                   \+    static_assert(unsigned(llvm::Attribute::name) ==                           \+                      unsigned(LLVM_Hs_AttributeKind_##name),                  \+                  "LLVM_Hs_AttributeKind enum out of sync w/ "                 \+                  "llvm::Attribute::AttrKind for " #name);+LLVM_HS_FOR_EACH_ATTRIBUTE_KIND(CHECK)+#undef CHECK++unsigned LLVM_Hs_AttributeKindAsEnum(LLVMAttributeRef a) {+    return unwrap(a).getKindAsEnum(); } -int LLVM_Hs_AttributeSetSlotIndex(const AttributeSetImpl *a, unsigned slot) {-	return unwrap(a).getSlotIndex(slot);+uint64_t LLVM_Hs_AttributeValueAsInt(LLVMAttributeRef a) {+    return unwrap(a).getValueAsInt(); } -const AttributeSetImpl *LLVM_Hs_AttributeSetSlotAttributes(const AttributeSetImpl *a, unsigned slot) {-	return wrap(unwrap(a).getSlotAttributes(slot));+LLVMBool LLVM_Hs_IsStringAttribute(LLVMAttributeRef a) {+    return unwrap(a).isStringAttribute(); } -const AttributeSetImpl *LLVM_Hs_GetSlotAttributeSet(-	LLVMContextRef context,-	unsigned index,-	const AttributeImpl **attributes,-	unsigned length-) {-	AttrBuilder builder;-	for (unsigned i = 0; i < length; i++) builder.addAttribute(unwrap(attributes[i]));-	return wrap(AttributeSet::get(*unwrap(context), index, builder));+const char *LLVM_Hs_AttributeKindAsString(LLVMAttributeRef a, size_t &l) {+    const StringRef s = unwrap(a).getKindAsString();+    l = s.size();+    return s.data(); } -const AttributeImpl *const *LLVM_Hs_AttributeSetGetAttributes(AttributeSetImpl *asi, unsigned slot, unsigned *length) {-	AttributeSet as = unwrap(asi);-	ArrayRef<Attribute>::iterator b = as.begin(slot), e = as.end(slot);-	*length = e - b;-	return reinterpret_cast<const AttributeImpl *const *>(b);+const char *LLVM_Hs_AttributeValueAsString(LLVMAttributeRef a, size_t &l) {+    const StringRef s = unwrap(a).getValueAsString();+    l = s.size();+    return s.data(); } -#define CHECK(name,p,r,f)																								\-	static_assert(																												\-		unsigned(llvm::Attribute::name) == unsigned(LLVM_Hs_AttributeKind_ ## name), \-		"LLVM_Hs_AttributeKind enum out of sync w/ llvm::Attribute::AttrKind for " #name	\-	);-	LLVM_HS_FOR_EACH_ATTRIBUTE_KIND(CHECK)-#undef CHECK+LLVMAttributeListRef LLVM_Hs_GetAttributeList(LLVMContextRef context,+                                              unsigned index,+                                              LLVMAttributeSetRef as) {+    return new AttributeList(AttributeList::get(*unwrap(context), index, *as));+} -unsigned LLVM_Hs_AttributeKindAsEnum(const AttributeImpl *a) {-    return unwrap(a).getKindAsEnum();+LLVMAttributeListRef LLVM_Hs_BuildAttributeList(LLVMContextRef context,+                                                LLVMAttributeSetRef fAttrs,+                                                LLVMAttributeSetRef rAttrs,+                                                LLVMAttributeSetRef *pAttrs,+                                                unsigned numPAttrs) {+    std::vector<AttributeSet> pAttrSets{numPAttrs};+    for (unsigned i = 0; i < numPAttrs; ++i) {+        pAttrSets[i] = *pAttrs[i];+    }+    return new AttributeList(+        AttributeList::get(*unwrap(context), *fAttrs, *rAttrs, pAttrSets)); } -uint64_t LLVM_Hs_AttributeValueAsInt(const AttributeImpl *a) {-	return unwrap(a).getValueAsInt();+void LLVM_Hs_DisposeAttributeList(LLVMAttributeListRef attributeList) {+    delete attributeList; } -LLVMBool LLVM_Hs_IsStringAttribute(const AttributeImpl *a) {-	return unwrap(a).isStringAttribute();+LLVMAttributeSetRef LLVM_Hs_GetAttributeSet(LLVMContextRef context,+                                            const AttrBuilder &ab) {+    return new AttributeSet(AttributeSet::get(*unwrap(context), ab)); } -const char *LLVM_Hs_AttributeKindAsString(const AttributeImpl *a, size_t &l) {-	const StringRef s = unwrap(a).getKindAsString();-	l = s.size();-	return s.data();+void LLVM_Hs_DisposeAttributeSet(LLVMAttributeListRef attributeList) {+    delete attributeList; } -const char *LLVM_Hs_AttributeValueAsString(const AttributeImpl *a, size_t &l) {-	const StringRef s = unwrap(a).getValueAsString();-	l = s.size();-	return s.data();+LLVMBool LLVM_Hs_AttributeSetsEqual(LLVMAttributeSetRef as1,+                                    LLVMAttributeSetRef as2) {+    return *as1 == *as2; } -const AttributeSetImpl *LLVM_Hs_GetAttributeSet(LLVMContextRef context, unsigned index, const AttrBuilder &ab) {-	return wrap(AttributeSet::get(*unwrap(context), index, ab));+LLVMBool LLVM_Hs_AttributeSetHasAttributes(LLVMAttributeSetRef as) {+    return as->hasAttributes(); } -const AttributeSetImpl *LLVM_Hs_MixAttributeSets(-	LLVMContextRef context, const AttributeSetImpl **as, unsigned n-) {-	return wrap(-		AttributeSet::get(-			*unwrap(context),-			ArrayRef<AttributeSet>(reinterpret_cast<const AttributeSet *>(as), n)-		)-	);+unsigned LLVM_Hs_getNumAttributes(LLVMAttributeSetRef attributeSet) {+    return attributeSet->getNumAttributes(); } +void LLVM_Hs_getAttributes(LLVMAttributeSetRef attributeSet,+                           LLVMAttributeRef *attrs) {+    for (auto a : *attributeSet) {+        *attrs++ = wrap(a);+    }+}+ size_t LLVM_Hs_GetAttrBuilderSize() { return sizeof(AttrBuilder); }  AttrBuilder *LLVM_Hs_ConstructAttrBuilder(char *p) {-	return new(p) AttrBuilder();+    return new (p) AttrBuilder(); } -void LLVM_Hs_DestroyAttrBuilder(AttrBuilder *a) {-	a->~AttrBuilder();+AttrBuilder *LLVM_Hs_AttrBuilderFromAttrSet(LLVMAttributeSetRef as) {+    return new AttrBuilder(*as); } +void LLVM_Hs_DisposeAttrBuilder(LLVMAttributeSetRef as) { delete as; }++void LLVM_Hs_AttrBuilderMerge(AttrBuilder *ab1, AttrBuilder *ab2) {+    ab1->merge(*ab2);+}++void LLVM_Hs_DestroyAttrBuilder(AttrBuilder *a) { a->~AttrBuilder(); }+ void LLVM_Hs_AttrBuilderAddAttributeKind(AttrBuilder &ab, unsigned kind) {     ab.addAttribute(Attribute::AttrKind(kind)); } -void LLVM_Hs_AttrBuilderAddStringAttribute(-	AttrBuilder &ab, const char *kind, size_t kind_len, const char *value, size_t value_len-) {-	ab.addAttribute(StringRef(kind, kind_len), StringRef(value, value_len));+void LLVM_Hs_AttrBuilderAddStringAttribute(AttrBuilder &ab, const char *kind,+                                           size_t kind_len, const char *value,+                                           size_t value_len) {+    ab.addAttribute(StringRef(kind, kind_len), StringRef(value, value_len)); }  void LLVM_Hs_AttrBuilderAddAlignment(AttrBuilder &ab, uint64_t v) {-	ab.addAlignmentAttr(v);+    ab.addAlignmentAttr(v); }  void LLVM_Hs_AttrBuilderAddStackAlignment(AttrBuilder &ab, uint64_t v) {-	ab.addStackAlignmentAttr(v);+    ab.addStackAlignmentAttr(v); } -void LLVM_Hs_AttrBuilderAddAllocSize(AttrBuilder &ab, unsigned x, unsigned y, LLVMBool optionalIsThere) {+void LLVM_Hs_AttrBuilderAddAllocSize(AttrBuilder &ab, unsigned x, unsigned y,+                                     LLVMBool optionalIsThere) {     if (optionalIsThere) {         ab.addAllocSizeAttr(x, Optional<unsigned>(y));     } else {@@ -124,14 +140,16 @@ }  void LLVM_Hs_AttrBuilderAddDereferenceableAttr(AttrBuilder &ab, uint64_t v) {-	ab.addDereferenceableAttr(v);+    ab.addDereferenceableAttr(v); } -void LLVM_Hs_AttrBuilderAddDereferenceableOrNullAttr(AttrBuilder &ab, uint64_t v) {+void LLVM_Hs_AttrBuilderAddDereferenceableOrNullAttr(AttrBuilder &ab,+                                                     uint64_t v) {     ab.addDereferenceableOrNullAttr(v); } -LLVMBool LLVM_Hs_AttributeGetAllocSizeArgs(const AttributeImpl* a, unsigned* x, unsigned* y) {+LLVMBool LLVM_Hs_AttributeGetAllocSizeArgs(LLVMAttributeRef a, unsigned *x,+                                           unsigned *y) {     auto pair = unwrap(a).getAllocSizeArgs();     *x = pair.first;     if (pair.second.hasValue()) {@@ -141,5 +159,4 @@         return 0;     } }- }

@@ -1,24 +1,11 @@ #ifndef __LLVM_ATTRIBUTE_C_HPP__ #define __LLVM_ATTRIBUTE_C_HPP__ #define __STDC_LIMIT_MACROS-#include "llvm/IR/Attributes.h" #include "LLVM/Internal/FFI/Attribute.h"+#include "llvm/IR/Attributes.h" using namespace llvm; -inline AttributeSet unwrap(const AttributeSetImpl *asi) {-    return *reinterpret_cast<const AttributeSet *>(&asi);-}--inline const AttributeSetImpl *wrap(AttributeSet as) {-    return *reinterpret_cast<const AttributeSetImpl **>(&as);-}--inline Attribute unwrap(const AttributeImpl *ai) {-    return *reinterpret_cast<const Attribute *>(&ai);-}--inline const AttributeImpl *wrap(Attribute a) {-    return *reinterpret_cast<const AttributeImpl **>(&a);-}+typedef AttributeSet *LLVMAttributeSetRef;+typedef AttributeList *LLVMAttributeListRef;  #endif

@@ -115,6 +115,7 @@ buildGetElementPtr :: Ptr Builder -> LLVMBool -> Ptr Value -> (CUInt, Ptr (Ptr Value)) -> CString -> IO (Ptr Instruction) buildGetElementPtr builder (LLVMBool 1) a (n, is) s = buildInBoundsGetElementPtr' builder a is n s buildGetElementPtr builder (LLVMBool 0) a (n, is) s = buildGetElementPtr' builder a is n s+buildGetElementPtr _ (LLVMBool i) _ _ _ = error ("LLVMBool should be 0 or 1 but is " <> show i)  foreign import ccall unsafe "LLVM_Hs_BuildFence" buildFence' ::   Ptr Builder -> MemoryOrdering -> SynchronizationScope -> CString -> IO (Ptr Instruction)

@@ -4,8 +4,9 @@  #include "llvm-c/Core.h" -#include "LLVM/Internal/FFI/Instruction.h" #include "LLVM/Internal/FFI/BinaryOperator.h"+#include "LLVM/Internal/FFI/ErrorHandling.hpp"+#include "LLVM/Internal/FFI/Instruction.h"  using namespace llvm; @@ -19,16 +20,15 @@ 	} } -static SynchronizationScope unwrap(LLVMSynchronizationScope l) {+static SyncScope::ID unwrap(LLVMSynchronizationScope l) { 	switch(l) {-#define ENUM_CASE(x) case LLVM ## x ## SynchronizationScope: return x;+#define ENUM_CASE(x) case LLVM ## x ## SynchronizationScope: return SyncScope::x; LLVM_HS_FOR_EACH_SYNCRONIZATION_SCOPE(ENUM_CASE) #undef ENUM_CASE-	default: return SynchronizationScope(0);+	default: reportFatalError("Unknown synchronization scope"); 	} } - static AtomicRMWInst::BinOp unwrap(LLVMAtomicRMWBinOp l) { 	switch(l) { #define ENUM_CASE(x) case LLVMAtomicRMWBinOp ## x: return AtomicRMWInst::x;@@ -40,7 +40,9 @@  static FastMathFlags unwrap(LLVMFastMathFlags f) { 	FastMathFlags r = FastMathFlags();-#define ENUM_CASE(x,l) if (f & LLVM ## x) r.set ## x();+#define ENUM_CASE_F(x,l) if (f & LLVM ## x) r.set ## x();+#define ENUM_CASE_T(x,l) if (f & LLVM ## x) r.set ## x(true);+#define ENUM_CASE(x,l,takesArg) ENUM_CASE_ ## takesArg(x,l) LLVM_HS_FOR_EACH_FAST_MATH_FLAG(ENUM_CASE) #undef ENUM_CASE 	return r;@@ -92,7 +94,7 @@ ) { 	LoadInst *i = unwrap(b)->CreateAlignedLoad(unwrap(p), align, isVolatile, name); 	i->setOrdering(unwrap(atomicOrdering));-	if (atomicOrdering != LLVMAtomicOrderingNotAtomic) i->setSynchScope(unwrap(synchScope));+	if (atomicOrdering != LLVMAtomicOrderingNotAtomic) i->setSyncScopeID(unwrap(synchScope)); 	return wrap(i); } @@ -109,7 +111,7 @@ 	StoreInst *i = unwrap(b)->CreateAlignedStore(unwrap(v), unwrap(p), align, isVolatile); 	i->setName(name); 	i->setOrdering(unwrap(atomicOrdering));-	if (atomicOrdering != LLVMAtomicOrderingNotAtomic) i->setSynchScope(unwrap(synchScope));+	if (atomicOrdering != LLVMAtomicOrderingNotAtomic) i->setSyncScopeID(unwrap(synchScope)); 	return wrap(i); } 

@@ -24,7 +24,7 @@   macro(SPIR_KERNEL, 76)                                \   macro(Intel_OCL_BI, 77)                               \   macro(X86_64_SysV, 78)                                \-  macro(X86_64_Win64, 79)+  macro(Win64, 79)  typedef enum { #define ENUM_CASE(l,n) LLVM_Hs_CallingConvention_ ## l = n,

@@ -23,9 +23,10 @@  foreignDecl :: String -> String -> [TypeQ] -> TypeQ -> DecsQ foreignDecl cName hName argTypeQs returnTypeQ = do-  let foreignDecl' hName argTypeQs = +  let retTyQ = appT (conT ''IO) returnTypeQ+      foreignDecl' hName argTypeQs =         forImpD cCall unsafe cName (mkName hName) -                  (foldr (\a b -> appT (appT arrowT a) b) (appT (conT ''IO) returnTypeQ) argTypeQs)+                  (foldr (\a b -> appT (appT arrowT a) b) retTyQ argTypeQs)       splitTuples :: [Type] -> Q ([Type], [Pat], [Exp])       splitTuples ts = do         let f :: Type -> Q (Seq Type, Pat, Seq Exp)@@ -56,6 +57,7 @@   let phName = hName ++ "'"   sequence [     foreignDecl' phName (map return ts),+    sigD (mkName hName) (foldr (\argT retT -> appT (appT arrowT argT) retT) retTyQ argTypeQs),     funD (mkName hName) [      clause (map return ps) (normalB (foldl appE (varE (mkName phName)) (map return es))) []     ]

@@ -115,7 +115,11 @@  constantGetElementPtr :: LLVMBool -> Ptr Constant -> (CUInt, Ptr (Ptr Constant)) -> IO (Ptr Constant) constantGetElementPtr (LLVMBool ib) a (n, is) =-  (case ib of { 0 -> constantGetElementPtr'; 1 -> constantInBoundsGetElementPtr' }) a is n+  (case ib of+     0 -> constantGetElementPtr'+     1 -> constantInBoundsGetElementPtr'+     _ -> error ("LLVMBool should be 0 or 1 but is " <> show ib)+  ) a is n  foreign import ccall unsafe "LLVM_Hs_GetConstCPPOpcode" getConstantCPPOpcode ::   Ptr Constant -> IO CPPOpcode

@@ -0,0 +1,8 @@+#include "LLVM/Internal/FFI/ErrorHandling.hpp"+#include <iostream>++void reportFatalError(const std::string &errorMsg) {+    std::cerr << "LLVM-HS ERROR at " << __FILE__ << ":" << __LINE__ << ": "+              << errorMsg << "\n ";+    exit(1);+}

@@ -0,0 +1,7 @@+#ifndef __LLVM_INTERNAL_FFI__ANALYSIS__H__+#define __LLVM_INTERNAL_FFI__ANALYSIS__H__+#include <string>++[[noreturn]] void reportFatalError(const std::string &errorMsg);++#endif

@@ -21,11 +21,11 @@ foreign import ccall unsafe "LLVMSetFunctionCallConv" setFunctionCallingConvention ::   Ptr Function -> CallingConvention -> IO () -foreign import ccall unsafe "LLVM_Hs_GetFunctionMixedAttributeSet" getMixedAttributeSet ::-  Ptr Function -> IO MixedAttributeSet+foreign import ccall unsafe "LLVM_Hs_SetFunctionAttributeList" setAttributeList ::+  Ptr Function -> AttributeList -> IO () -foreign import ccall unsafe "LLVM_Hs_SetFunctionMixedAttributeSet" setMixedAttributeSet ::-  Ptr Function -> MixedAttributeSet -> IO ()+foreign import ccall unsafe "LLVM_Hs_FunctionAttributesAtIndex" attributesAtIndex ::+  Ptr Function -> AttributeIndex -> IO (AttributeSet b)  foreign import ccall unsafe "LLVMGetFirstBasicBlock" getFirstBasicBlock ::   Ptr Function -> IO (Ptr BasicBlock)

@@ -1,41 +1,42 @@ #define __STDC_LIMIT_MACROS-#include "llvm/IR/LLVMContext.h" #include "llvm/IR/Attributes.h" #include "llvm/IR/Function.h"+#include "llvm/IR/LLVMContext.h" #include "llvm/IR/Value.h" -#include "llvm-c/Core.h" #include "LLVM/Internal/FFI/AttributeC.hpp"+#include "llvm-c/Core.h"  using namespace llvm;  extern "C" {--const AttributeSetImpl *LLVM_Hs_GetFunctionMixedAttributeSet(LLVMValueRef f) {-	return wrap(unwrap<Function>(f)->getAttributes());-}--void LLVM_Hs_SetFunctionMixedAttributeSet(LLVMValueRef f, AttributeSetImpl *asi) {-	unwrap<Function>(f)->setAttributes(unwrap(asi));+void LLVM_Hs_SetFunctionAttributeList(LLVMValueRef f,+                                      LLVMAttributeListRef attrs) {+    unwrap<Function>(f)->setAttributes(*attrs); }  LLVMBool LLVM_Hs_HasFunctionPrefixData(LLVMValueRef f) {-  return unwrap<Function>(f)->hasPrefixData();+    return unwrap<Function>(f)->hasPrefixData(); }  LLVMValueRef LLVM_Hs_GetFunctionPrefixData(LLVMValueRef f) {-  return wrap(unwrap<Function>(f)->getPrefixData());+    return wrap(unwrap<Function>(f)->getPrefixData()); }  void LLVM_Hs_SetFunctionPrefixData(LLVMValueRef f, LLVMValueRef p) {-  unwrap<Function>(f)->setPrefixData(unwrap<Constant>(p));+    unwrap<Function>(f)->setPrefixData(unwrap<Constant>(p)); }  // This wrapper is necessary because LLVMSetPersonalityFn fails if // personalityFn is a nullptr even though the C++ API allows that. void LLVM_Hs_SetPersonalityFn(LLVMValueRef fn, LLVMValueRef personalityFn) {-    unwrap<Function>(fn)->setPersonalityFn(personalityFn == nullptr ?-                                           nullptr : unwrap<Constant>(personalityFn));+    unwrap<Function>(fn)->setPersonalityFn(+        personalityFn == nullptr ? nullptr : unwrap<Constant>(personalityFn)); } +LLVMAttributeSetRef LLVM_Hs_FunctionAttributesAtIndex(LLVMValueRef fn,+                                                      LLVMAttributeIndex idx) {+    return new AttributeSet(+        unwrap<Function>(fn)->getAttributes().getAttributes(idx));+} }

@@ -27,7 +27,7 @@  #define LLVM_HS_FOR_EACH_SYNCRONIZATION_SCOPE(macro) \ 	macro(SingleThread) \-	macro(CrossThread)+	macro(System)  typedef enum { #define ENUM_CASE(x) LLVM ## x ## SynchronizationScope,@@ -35,21 +35,23 @@ #undef ENUM_CASE } LLVMSynchronizationScope; +/* 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)								\-	macro(NoNaNs, noNaNs)															\-	macro(NoInfs, noInfs)															\-	macro(NoSignedZeros, noSignedZeros)								\-	macro(AllowReciprocal, allowReciprocal)+	macro(UnsafeAlgebra, unsafeAlgebra, F)								\+	macro(NoNaNs, noNaNs, F)                                              \+	macro(NoInfs, noInfs, F)                                              \+	macro(NoSignedZeros, noSignedZeros, F)								\+	macro(AllowReciprocal, allowReciprocal, F)                            \+    macro(AllowContract, allowContract, T)  typedef enum {-#define ENUM_CASE(x,l) LLVM ## x ## Bit,+#define ENUM_CASE(x,l,takesArg) LLVM ## x ## Bit, LLVM_HS_FOR_EACH_FAST_MATH_FLAG(ENUM_CASE) #undef ENUM_CASE } LLVMFastMathFlagBit;  typedef enum {-#define ENUM_CASE(x,l) LLVM ## x = (1 << LLVM ## x ## Bit),+#define ENUM_CASE(x,l,takesArg) LLVM ## x = (1 << LLVM ## x ## Bit), LLVM_HS_FOR_EACH_FAST_MATH_FLAG(ENUM_CASE) #undef ENUM_CASE } LLVMFastMathFlags;

@@ -46,20 +46,25 @@ foreign import ccall unsafe "LLVM_Hs_SetTailCallKind" setTailCallKind ::   Ptr Instruction -> TailCallKind -> IO () -foreign import ccall unsafe "LLVM_Hs_GetCallSiteCalledValue" getCallSiteCalledValue ::+foreign import ccall unsafe "LLVMGetCalledValue" getCallSiteCalledValue ::   Ptr Instruction -> IO (Ptr Value) -foreign import ccall unsafe "LLVM_Hs_GetCallSiteAttributeSet" getCallSiteAttributeSet ::-  Ptr Instruction -> IO MixedAttributeSet+foreign import ccall unsafe "LLVMGetNumArgOperands" getCallSiteNumArgOperands ::+  Ptr Instruction -> IO CUInt -foreign import ccall unsafe "LLVM_Hs_SetCallSiteAttributeSet" setCallSiteAttributeSet ::-  Ptr Instruction -> MixedAttributeSet -> IO ()+foreign import ccall unsafe "LLVM_Hs_CallSiteAttributesAtIndex" getCallSiteAttributesAtIndex ::+  Ptr Instruction -> AttributeIndex -> IO (AttributeSet a)++foreign import ccall unsafe "LLVM_Hs_CallSiteSetAttributeList" setCallSiteAttributeList ::+  Ptr Instruction -> AttributeList -> IO ()                       foreign import ccall unsafe "LLVMAddIncoming" addIncoming' ::   Ptr Instruction -> Ptr (Ptr Value) -> Ptr (Ptr BasicBlock) -> CUInt -> IO ()  addIncoming :: Ptr Instruction -> (CUInt, Ptr (Ptr Value)) -> (CUInt, Ptr (Ptr BasicBlock)) -> IO ()-addIncoming i (nvs, vs) (nbs, bs) | nbs == nvs = addIncoming' i vs bs nbs+addIncoming i (nvs, vs) (nbs, bs)+  | nbs == nvs = addIncoming' i vs bs nbs+  | otherwise = error "Number of incoming values and incoming blocks must be equal"  foreign import ccall unsafe "LLVMCountIncoming" countIncoming ::   Ptr Instruction -> IO CUInt

@@ -10,8 +10,8 @@  #include "llvm-c/Core.h" -#include "LLVM/Internal/FFI/Metadata.hpp" #include "LLVM/Internal/FFI/AttributeC.hpp"+#include "LLVM/Internal/FFI/ErrorHandling.hpp" #include "LLVM/Internal/FFI/Instruction.h"  using namespace llvm;@@ -27,12 +27,12 @@ 	} } -static LLVMSynchronizationScope wrap(SynchronizationScope l) {+static LLVMSynchronizationScope wrap(SyncScope::ID l) { 	switch(l) {-#define ENUM_CASE(x) case x: return LLVM ## x ## SynchronizationScope;+#define ENUM_CASE(x) case SyncScope::x: return LLVM ## x ## SynchronizationScope; LLVM_HS_FOR_EACH_SYNCRONIZATION_SCOPE(ENUM_CASE) #undef ENUM_CASE-	default: return LLVMSynchronizationScope(0);+    default: reportFatalError("Unknown synchronization scope"); 	} } @@ -47,10 +47,10 @@  LLVMFastMathFlags wrap(FastMathFlags f) { 	unsigned r = 0;-#define ENUM_CASE(u,l) if (f.l()) r |= unsigned(LLVM ## u);+#define ENUM_CASE(u,l,takesArg) if (f.l()) r |= unsigned(LLVM ## u); LLVM_HS_FOR_EACH_FAST_MATH_FLAG(ENUM_CASE) #undef ENUM_CASE-	return LLVMFastMathFlags(r);+    return LLVMFastMathFlags(r); }  }@@ -77,16 +77,8 @@ 	return wrap(unwrap<Instruction>(val)->getFastMathFlags()); } -LLVMValueRef LLVM_Hs_GetCallSiteCalledValue(LLVMValueRef i) {-	return wrap(CallSite(unwrap<Instruction>(i)).getCalledValue());-}--const AttributeSetImpl *LLVM_Hs_GetCallSiteAttributeSet(LLVMValueRef i) {-	return wrap(CallSite(unwrap<Instruction>(i)).getAttributes());-}--void LLVM_Hs_SetCallSiteAttributeSet(LLVMValueRef i, const AttributeSetImpl *asi) {-	CallSite(unwrap<Instruction>(i)).setAttributes(unwrap(asi));+void LLVM_Hs_CallSiteSetAttributeList(LLVMValueRef i, LLVMAttributeListRef attrs) {+	CallSite(unwrap<Instruction>(i)).setAttributes(*attrs); }  unsigned LLVM_Hs_GetCallSiteCallingConvention(LLVMValueRef i) {@@ -97,6 +89,11 @@   CallSite(unwrap<Instruction>(i)).setCallingConv(llvm::CallingConv::ID(cc)); } +LLVMAttributeSetRef LLVM_Hs_CallSiteAttributesAtIndex(LLVMValueRef i, LLVMAttributeIndex idx) {+    auto cs = CallSite(unwrap<Instruction>(i));+    return new AttributeSet(cs.getAttributes().getAttributes(idx));+}+ #define CHECK(name)                                                            \     static_assert(unsigned(llvm::CallInst::TCK_##name) ==                      \                       unsigned(LLVM_Hs_TailCallKind_##name),              \@@ -172,7 +169,7 @@  LLVMSynchronizationScope LLVM_Hs_GetSynchronizationScope(LLVMValueRef i) { 	switch(unwrap<Instruction>(i)->getOpcode()) {-#define ENUM_CASE(n,s) case Instruction::n: return wrap(unwrap<n ## Inst>(i)->getSynchScope());+#define ENUM_CASE(n,s) case Instruction::n: return wrap(unwrap<n ## Inst>(i)->getSyncScopeID()); 		LLVM_HS_FOR_EACH_ATOMIC_INST(ENUM_CASE) #undef ENUM_CASE 	default: return LLVMSynchronizationScope(0);@@ -233,8 +230,8 @@ ) { 	SwitchInst *s = unwrap<SwitchInst>(v); 	for(SwitchInst::CaseIt i = s->case_begin(); i != s->case_end(); ++i, ++values, ++dests) {-		*values = wrap(i.getCaseValue());-		*dests = wrap(i.getCaseSuccessor());+		*values = wrap(i->getCaseValue());+		*dests = wrap(i->getCaseSuccessor()); 	} } @@ -245,10 +242,6 @@ 	IndirectBrInst *ib = unwrap<IndirectBrInst>(v); 	for(unsigned i=0; i != ib->getNumDestinations(); ++i, ++dests) 		*dests = wrap(ib->getDestination(i));-}--inline Metadata **unwrap(LLVMMetadataRef *vals) {-    return reinterpret_cast<Metadata**>(vals); }  void LLVM_Hs_SetMetadata(LLVMValueRef inst, unsigned kindID, LLVMMetadataRef md) {

@@ -26,7 +26,7 @@ define hsc_inject() {                                       \   hsc_printf("[");                                       \   struct inst *i;                                           \-  const char *kind;                                         \+  const char *kind = NULL;                                  \   int first = 1;                                            \   for(i = insts; i->kind || i->opcode; ++i) {               \     if (i->kind) { kind = i->kind; continue; }              \

@@ -7,7 +7,9 @@  import LLVM.Prelude +#ifndef __STDC_LIMIT_MACROS #define __STDC_LIMIT_MACROS+#endif #include "llvm-c/Core.h" #include "llvm-c/Linker.h" #include "llvm-c/OrcBindings.h"@@ -115,7 +117,7 @@  newtype FastMathFlags = FastMathFlags CUInt   deriving (Eq, Ord, Show, Typeable, Data, Num, Bits, Generic)-#define FMF_Rec(n,l) { #n, LLVM ## n, },+#define FMF_Rec(n,l,ignored) { #n, LLVM ## n, }, #{inject FAST_MATH_FLAG, FastMathFlags, FastMathFlags, fastMathFlags, FMF_Rec}  newtype MemoryOrdering = MemoryOrdering CUInt@@ -222,6 +224,11 @@   deriving (Eq, Read, Show, Typeable, Data, Generic) #define TOF_Rec(n) { #n, LLVM_Hs_TargetOptionFlag_ ## n }, #{inject TARGET_OPTION_FLAG, TargetOptionFlag, TargetOptionFlag, targetOptionFlag, TOF_Rec}++newtype DebugCompressionType = DebugCompressionType CUInt+  deriving (Eq, Read, Show, Typeable, Data, Generic)+#define DCT_Rec(n) { #n, LLVM_Hs_DebugCompressionType_ ## n },+#{inject DEBUG_COMPRESSION_TYPE, DebugCompressionType, DebugCompressionType, debugCompressionType, DCT_Rec}  newtype TypeKind = TypeKind CUInt   deriving (Eq, Read, Show, Typeable, Data, Generic)

@@ -1,11 +0,0 @@-#include "llvm/IR/Metadata.h"-#include "llvm-c/Core.h"--namespace llvm {-typedef struct LLVMOpaqueMetadata *LLVMMetadataRef;-DEFINE_ISA_CONVERSION_FUNCTIONS(Metadata, LLVMMetadataRef)--inline Metadata **unwrap(LLVMMetadataRef *Vals) {-  return reinterpret_cast<Metadata**>(Vals);-}-}

@@ -1,7 +1,6 @@ #define __STDC_LIMIT_MACROS  #include <iostream>-#include "LLVM/Internal/FFI/Metadata.hpp" #include "llvm/Support/FormattedStream.h"  #include "llvm/Config/llvm-config.h"

@@ -42,7 +42,7 @@   Ptr LinkingLayer -> IO ()  foreign import ccall safe "LLVM_Hs_JITSymbol_getAddress" getAddress ::-  Ptr JITSymbol -> IO TargetAddress+  Ptr JITSymbol -> Ptr (OwnerTransfered CString) -> IO TargetAddress  foreign import ccall safe "LLVM_Hs_JITSymbol_getFlags" getFlags ::   Ptr JITSymbol -> IO JITSymbolFlags

@@ -13,25 +13,25 @@  data CompileLayer --- | Abstract type representing a set of modules in a 'LLVM.OrcJIT.CompileLayer'.-newtype ModuleSetHandle = ModuleSetHandle Word+-- | Abstract type representing a module in a 'LLVM.OrcJIT.CompileLayer'.+newtype ModuleHandle = ModuleHandle Word  foreign import ccall safe "LLVM_Hs_CompileLayer_dispose" disposeCompileLayer ::   Ptr CompileLayer -> IO () -foreign import ccall safe "LLVM_Hs_CompileLayer_addModuleSet" addModuleSet ::+foreign import ccall safe "LLVM_Hs_CompileLayer_addModule" addModule ::   Ptr CompileLayer ->   Ptr DataLayout ->-  Ptr (Ptr Module) ->-  CUInt ->+  Ptr Module ->   Ptr LambdaResolver ->-  IO ModuleSetHandle+  Ptr (OwnerTransfered CString) ->+  IO ModuleHandle -foreign import ccall safe "LLVM_Hs_CompileLayer_removeModuleSet" removeModuleSet ::-  Ptr CompileLayer -> ModuleSetHandle -> IO ()+foreign import ccall safe "LLVM_Hs_CompileLayer_removeModule" removeModule ::+  Ptr CompileLayer -> ModuleHandle -> IO ()  foreign import ccall safe "LLVM_Hs_CompileLayer_findSymbol" findSymbol ::   Ptr CompileLayer -> CString -> LLVMBool -> IO (Ptr JITSymbol)  foreign import ccall safe "LLVM_Hs_CompileLayer_findSymbolIn" findSymbolIn ::-  Ptr CompileLayer -> ModuleSetHandle -> CString -> LLVMBool -> IO (Ptr JITSymbol)+  Ptr CompileLayer -> ModuleHandle -> CString -> LLVMBool -> IO (Ptr JITSymbol)

@@ -1,3 +1,5 @@+#include "llvm/Support/Error.h"+ #include "LLVM/Internal/FFI/OrcJIT.h" #include "LLVM/Internal/FFI/Target.hpp" #include "llvm/ExecutionEngine/JITSymbol.h"@@ -7,7 +9,8 @@ #include "llvm/ExecutionEngine/Orc/IRTransformLayer.h" #include "llvm/ExecutionEngine/Orc/IndirectionUtils.h" #include "llvm/ExecutionEngine/Orc/LambdaResolver.h"-#include "llvm/ExecutionEngine/Orc/ObjectLinkingLayer.h"+#include "llvm/ExecutionEngine/Orc/RTDyldObjectLinkingLayer.h"+#include "llvm/ExecutionEngine/SectionMemoryManager.h" #include "llvm/IR/Mangler.h"  #include <type_traits>@@ -16,13 +19,13 @@ using namespace llvm; using namespace orc; -typedef unsigned LLVMModuleSetHandle;+typedef unsigned LLVMModuleHandle; typedef unsigned LLVMObjSetHandle; typedef llvm::orc::LambdaResolver<     std::function<JITSymbol(const std::string &name)>,     std::function<JITSymbol(const std::string &name)>>     LLVMLambdaResolver;-typedef LLVMLambdaResolver *LLVMLambdaResolverRef;+typedef std::shared_ptr<LLVMLambdaResolver> *LLVMLambdaResolverRef;  // We want to allow users to choose themselves which layers they want to use. // However, the LLVM API requires that this is selected statically via template@@ -49,154 +52,97 @@ class LinkingLayer {   public:     virtual ~LinkingLayer(){};-    typedef unsigned ObjSetHandleT;-    virtual ObjSetHandleT-    addObjectSet(std::vector<std::unique_ptr<object::ObjectFile>> objects,-                 SectionMemoryManager *memMgr, JITSymbolResolver *resolver) = 0;-    virtual ObjSetHandleT addObjectSet(-        std::vector<std::unique_ptr<object::OwningBinary<object::ObjectFile>>>-            objects,-        SectionMemoryManager *memMgr, JITSymbolResolver *resolver) = 0;-    virtual ObjSetHandleT addObjectSet(-        std::vector<std::unique_ptr<object::OwningBinary<object::ObjectFile>>>-            objects,-        std::unique_ptr<SectionMemoryManager> memMgr,-        JITSymbolResolver *resolver) = 0;-    virtual ObjSetHandleT addObjectSet(-        std::vector<std::unique_ptr<object::OwningBinary<object::ObjectFile>>>-            objects,-        std::unique_ptr<SectionMemoryManager> memMgr,-        std::unique_ptr<JITSymbolResolver> resolver) = 0;-    virtual ObjSetHandleT addObjectSet(-        std::vector<std::unique_ptr<object::OwningBinary<object::ObjectFile>>>-            objects,-        SectionMemoryManager *memMgr,-        std::unique_ptr<JITSymbolResolver> resolver) = 0;-    virtual void removeObjectSet(ObjSetHandleT H) = 0;+    typedef unsigned ObjHandleT;+    virtual Expected<ObjHandleT>+    addObject(std::shared_ptr<object::OwningBinary<object::ObjectFile>> object,+              std::shared_ptr<JITSymbolResolver> resolver) = 0;+    virtual Error removeObject(ObjHandleT H) = 0;     virtual JITSymbol findSymbol(StringRef name, bool exportedSymbolsOnly) = 0;-    virtual JITSymbol findSymbolIn(ObjSetHandleT h, StringRef name,+    virtual JITSymbol findSymbolIn(ObjHandleT h, StringRef name,                                    bool exportedSymbolsOnly) = 0;-    virtual void emitAndFinalize(ObjSetHandleT h) = 0;+    virtual void emitAndFinalize(ObjHandleT h) = 0; };  template <typename T> class LinkingLayerT : public LinkingLayer {   public:     LinkingLayerT(T data_) : data(std::move(data_)) {}-    ObjSetHandleT-    addObjectSet(std::vector<std::unique_ptr<object::ObjectFile>> objects,-                 SectionMemoryManager *memMgr,-                 JITSymbolResolver *resolver) override {-        auto handle = data.addObjectSet(std::move(objects), std::move(memMgr),-                                        std::move(resolver));-        return handles.insert(handle);-    }-    ObjSetHandleT addObjectSet(-        std::vector<std::unique_ptr<object::OwningBinary<object::ObjectFile>>>-            objects,-        SectionMemoryManager *memMgr, JITSymbolResolver *resolver) override {-        auto handle = data.addObjectSet(std::move(objects), std::move(memMgr),-                                        std::move(resolver));-        return handles.insert(handle);-    }-    ObjSetHandleT addObjectSet(-        std::vector<std::unique_ptr<object::OwningBinary<object::ObjectFile>>>-            objects,-        std::unique_ptr<SectionMemoryManager> memMgr,-        JITSymbolResolver *resolver) override {-        auto handle = data.addObjectSet(std::move(objects), std::move(memMgr),-                                        std::move(resolver));-        return handles.insert(handle);-    }-    ObjSetHandleT addObjectSet(-        std::vector<std::unique_ptr<object::OwningBinary<object::ObjectFile>>>-            objects,-        std::unique_ptr<SectionMemoryManager> memMgr,-        std::unique_ptr<JITSymbolResolver> resolver) override {-        auto handle = data.addObjectSet(std::move(objects), std::move(memMgr),-                                        std::move(resolver));-        return handles.insert(handle);-    }-    ObjSetHandleT addObjectSet(-        std::vector<std::unique_ptr<object::OwningBinary<object::ObjectFile>>>-            objects,-        SectionMemoryManager *memMgr,-        std::unique_ptr<JITSymbolResolver> resolver) override {-        auto handle = data.addObjectSet(std::move(objects), std::move(memMgr),-                                        std::move(resolver));-        return handles.insert(handle);+    Expected<ObjHandleT>+    addObject(std::shared_ptr<object::OwningBinary<object::ObjectFile>> object,+              std::shared_ptr<JITSymbolResolver> resolver) override {+        if (auto handleOrErr =+                data.addObject(std::move(object), std::move(resolver))) {+            return handles.insert(*handleOrErr);+        } else {+            return handleOrErr.takeError();+        }     }-    void removeObjectSet(ObjSetHandleT h) override {-        data.removeObjectSet(handles.lookup(h));-        handles.remove(h);+    Error removeObject(ObjHandleT h) override {+        if (auto err = data.removeObject(handles.lookup(h))) {+            return err;+        } else {+            handles.remove(h);+            return err;+        }     }     JITSymbol findSymbol(StringRef name, bool exportedSymbolsOnly) override {         return data.findSymbol(name, exportedSymbolsOnly);     }-    JITSymbol findSymbolIn(ObjSetHandleT h, StringRef name,+    JITSymbol findSymbolIn(ObjHandleT h, StringRef name,                            bool exportedSymbolsOnly) override {         return data.findSymbolIn(handles.lookup(h), name, exportedSymbolsOnly);     }-    void emitAndFinalize(ObjSetHandleT h) override {+    void emitAndFinalize(ObjHandleT h) override {         data.emitAndFinalize(handles.lookup(h));     }    private:     T data;-    HandleSet<typename T::ObjSetHandleT> handles;+    HandleSet<typename T::ObjHandleT> handles; };  class CompileLayer {   public:-    typedef LLVMModuleSetHandle ModuleSetHandleT;+    typedef LLVMModuleHandle ModuleHandleT;     virtual ~CompileLayer(){};     virtual JITSymbol findSymbol(StringRef Name, bool ExportedSymbolsOnly) = 0;-    virtual JITSymbol findSymbolIn(ModuleSetHandleT H, StringRef Name,+    virtual JITSymbol findSymbolIn(ModuleHandleT H, StringRef Name,                                    bool ExportedSymbolsOnly) = 0;-    virtual ModuleSetHandleT-    addModuleSet(std::vector<std::unique_ptr<Module>> Modules,-                 std::unique_ptr<SectionMemoryManager> MemMgr,-                 std::unique_ptr<JITSymbolResolver> Resolver) = 0;-    virtual ModuleSetHandleT-    addModuleSet(std::vector<std::unique_ptr<Module>> Modules,-                 SectionMemoryManager *MemMgr,-                 std::unique_ptr<JITSymbolResolver> Resolver) = 0;-    virtual void removeModuleSet(ModuleSetHandleT H) = 0;+    virtual Expected<ModuleHandleT>+    addModule(std::shared_ptr<Module> Modules,+              std::shared_ptr<JITSymbolResolver> Resolver) = 0;+    virtual Error removeModule(ModuleHandleT H) = 0; };  template <typename T> class CompileLayerT : public CompileLayer {   public:-    CompileLayerT(T data_) : data(std::move(data_)) {}+    template <typename... Arg>+    CompileLayerT(Arg &&... arg) : data{std::forward<Arg>(arg)...} {}     JITSymbol findSymbol(StringRef Name, bool ExportedSymbolsOnly) override {         return data.findSymbol(Name, ExportedSymbolsOnly);     }-    JITSymbol findSymbolIn(ModuleSetHandleT H, StringRef Name,+    JITSymbol findSymbolIn(ModuleHandleT H, StringRef Name,                            bool ExportedSymbolsOnly) override {         return data.findSymbolIn(handles.lookup(H), Name, ExportedSymbolsOnly);     }-    ModuleSetHandleT-    addModuleSet(std::vector<std::unique_ptr<Module>> Modules,-                 std::unique_ptr<SectionMemoryManager> MemMgr,-                 std::unique_ptr<JITSymbolResolver> Resolver) override {-        auto handle = data.addModuleSet(std::move(Modules), std::move(MemMgr),-                                        std::move(Resolver));-        return handles.insert(handle);-    }-    ModuleSetHandleT-    addModuleSet(std::vector<std::unique_ptr<Module>> Modules,-                 SectionMemoryManager *MemMgr,-                 std::unique_ptr<JITSymbolResolver> Resolver) override {-        auto handle = data.addModuleSet(std::move(Modules), std::move(MemMgr),-                                        std::move(Resolver));-        return handles.insert(handle);+    Expected<ModuleHandleT>+    addModule(std::shared_ptr<Module> Module,+              std::shared_ptr<JITSymbolResolver> Resolver) override {+        if (auto handleOrErr =+                data.addModule(std::move(Module), std::move(Resolver))) {+            return handles.insert(*handleOrErr);+        } else {+            return handleOrErr.takeError();+        }     }-    void removeModuleSet(ModuleSetHandleT H) override {-        data.removeModuleSet(handles.lookup(H));+    Error removeModule(ModuleHandleT H) override {+        auto handle = handles.lookup(H);         handles.remove(H);+        return data.removeModule(handle);     }    private:     T data;-    HandleSet<typename T::ModuleSetHandleT> handles;+    HandleSet<typename T::ModuleHandleT> handles; };  typedef llvm::orc::CompileOnDemandLayer<CompileLayer> LLVMCompileOnDemandLayer;@@ -204,7 +150,7 @@  typedef llvm::orc::IRTransformLayer<     CompileLayer,-    std::function<std::unique_ptr<Module>(std::unique_ptr<Module>)>>+    std::function<std::shared_ptr<Module>(std::shared_ptr<Module>)>>     LLVMIRTransformLayer;  typedef llvm::orc::JITCompileCallbackManager *LLVMJITCompileCallbackManagerRef;@@ -225,19 +171,6 @@     return mangledName; } -static std::vector<std::unique_ptr<Module>>-getModules(LLVMModuleRef *modules, unsigned moduleCount,-           LLVMTargetDataRef dataLayout) {-    std::vector<std::unique_ptr<Module>> moduleVec(moduleCount);-    for (unsigned i = 0; i < moduleCount; ++i) {-        moduleVec.at(i) = std::unique_ptr<Module>(unwrap(modules[i]));-        if (moduleVec.at(i)->getDataLayout().isDefault()) {-            moduleVec.at(i)->setDataLayout(*unwrap(dataLayout));-        }-    }-    return moduleVec;-}- extern "C" {  /* Constructor functions for the different compile layers */@@ -245,8 +178,9 @@ CompileLayer *LLVM_Hs_createIRCompileLayer(LinkingLayer *linkingLayer,                                            LLVMTargetMachineRef tm) {     TargetMachine *tmm = unwrap(tm);-    return new CompileLayerT<IRCompileLayer<LinkingLayer>>(-        IRCompileLayer<LinkingLayer>(*linkingLayer, SimpleCompiler(*tmm)));+    return new CompileLayerT<IRCompileLayer<LinkingLayer, SimpleCompiler>>(+        IRCompileLayer<LinkingLayer, SimpleCompiler>(*linkingLayer,+                                                     SimpleCompiler(*tmm))); }  CompileLayer *LLVM_Hs_createCompileOnDemandLayer(@@ -255,24 +189,24 @@     LLVMJITCompileCallbackManagerRef callbackManager,     LLVMIndirectStubsManagerBuilderRef stubsManager,     LLVMBool cloneStubsIntoPartitions) {-    return new CompileLayerT<LLVMCompileOnDemandLayer>(LLVMCompileOnDemandLayer(+    return new CompileLayerT<LLVMCompileOnDemandLayer>(         *compileLayer,         [partitioningFtor](llvm::Function &f) -> std::set<llvm::Function *> {             std::set<llvm::Function *> result;             partitioningFtor(&f, &result);             return result;         },-        *callbackManager, *stubsManager, cloneStubsIntoPartitions));+        *callbackManager, *stubsManager,+        static_cast<bool>(cloneStubsIntoPartitions)); }  CompileLayer *LLVM_Hs_createIRTransformLayer(CompileLayer *compileLayer,                                              Module *(*transform)(Module *)) {-    std::function<std::unique_ptr<Module>(std::unique_ptr<Module>)> transform_ =-        [transform](std::unique_ptr<Module> module) {-            return std::unique_ptr<Module>(transform(module.release()));+    std::function<std::shared_ptr<Module>(std::shared_ptr<Module>)> transform_ =+        [transform](std::shared_ptr<Module> module) {+            return std::shared_ptr<Module>(transform(module.get()));         };-    return new CompileLayerT<LLVMIRTransformLayer>(-        LLVMIRTransformLayer(*compileLayer, transform_));+    return new CompileLayerT<LLVMIRTransformLayer>(*compileLayer, transform_); }  /* Functions that work on all compile layers */@@ -285,40 +219,49 @@                                                  const char *name,                                                  LLVMBool exportedSymbolsOnly) {     JITSymbol symbol = compileLayer->findSymbol(name, exportedSymbolsOnly);-    return new JITSymbol(symbol);+    return new JITSymbol(std::move(symbol)); }  LLVMJITSymbolRef LLVM_Hs_CompileLayer_findSymbolIn(CompileLayer *compileLayer,-                                  LLVMModuleSetHandle handle, const char *name,+                                  LLVMModuleHandle handle, const char *name,                                   LLVMBool exportedSymbolsOnly) {     JITSymbol symbol =         compileLayer->findSymbolIn(handle, name, exportedSymbolsOnly);-    return new JITSymbol(symbol);+    return new JITSymbol(std::move(symbol)); } -LLVMModuleSetHandle-LLVM_Hs_CompileLayer_addModuleSet(CompileLayer *compileLayer,-                                  LLVMTargetDataRef dataLayout,-                                  LLVMModuleRef *modules, unsigned moduleCount,-                                  LLVMLambdaResolverRef resolver) {-    auto moduleVec = getModules(modules, moduleCount, dataLayout);-    std::unique_ptr<LLVMLambdaResolver> uniqueResolver(-        new LLVMLambdaResolver(*resolver));-    return compileLayer->addModuleSet(std::move(moduleVec),-                                      make_unique<SectionMemoryManager>(),-                                      std::move(uniqueResolver));+LLVMModuleHandle LLVM_Hs_CompileLayer_addModule(CompileLayer *compileLayer,+                                                LLVMTargetDataRef dataLayout,+                                                LLVMModuleRef module,+                                                LLVMLambdaResolverRef resolver,+                                                char **errorMessage) {+    std::shared_ptr<Module> mod{unwrap(module), [](Module *) {}};+    if (mod->getDataLayout().isDefault()) {+        mod->setDataLayout(*unwrap(dataLayout));+    }+    if (auto handleOrErr = compileLayer->addModule(std::move(mod), *resolver)) {+        *errorMessage = nullptr;+        return *handleOrErr;+    } else {+        std::string errString = toString(handleOrErr.takeError());+        *errorMessage = strdup(errString.c_str());+        return 0;+    } } -void LLVM_Hs_CompileLayer_removeModuleSet(CompileLayer *compileLayer,-                                          LLVMModuleSetHandle moduleSetHandle) {-    compileLayer->removeModuleSet(moduleSetHandle);+void LLVM_Hs_CompileLayer_removeModule(CompileLayer *compileLayer,+                                       LLVMModuleHandle moduleSetHandle) {+    if (compileLayer->removeModule(moduleSetHandle)) {+        // TODO handle failure+    } }  /* Constructor functions for the different object layers */  LinkingLayer *LLVM_Hs_createObjectLinkingLayer() {-    return new LinkingLayerT<ObjectLinkingLayer<>>(ObjectLinkingLayer<>());+    return new LinkingLayerT<RTDyldObjectLinkingLayer>(RTDyldObjectLinkingLayer(+        []() { return std::make_shared<SectionMemoryManager>(); })); }  /* Fuctions that work on all object layers */@@ -344,9 +287,8 @@         externalResolver(name.c_str(), &symbol);         return symbol;     };-    auto lambdaResolver =-        createLambdaResolver(dylibResolverFun, externalResolverFun);-    return lambdaResolver.release();+    return new std::shared_ptr<LLVMLambdaResolver>(+        createLambdaResolver(dylibResolverFun, externalResolverFun)); }  static JITSymbolFlags unwrap(LLVMJITSymbolFlags f) {@@ -369,8 +311,16 @@     return LLVMJITSymbolFlags(r); } -JITTargetAddress LLVM_Hs_JITSymbol_getAddress(LLVMJITSymbolRef symbol) {-    return symbol->getAddress();+JITTargetAddress LLVM_Hs_JITSymbol_getAddress(LLVMJITSymbolRef symbol,+                                              char **errorMessage) {+    *errorMessage = nullptr;+    if (auto addrOrErr = symbol->getAddress()) {+        return *addrOrErr;+    } else {+        std::string error = toString(addrOrErr.takeError());+        *errorMessage = strdup(error.c_str());+        return 0;+    } }  LLVMJITSymbolFlags LLVM_Hs_JITSymbol_getFlags(LLVMJITSymbolRef symbol) {

@@ -86,7 +86,7 @@   liftM concat $ forM cons $ \con -> case con of     TH.RecC n l -> declareForeign n [ t | (_,_,t) <- l ]     TH.NormalC n [] -> declareForeign n []-    TH.NormalC n _ -> error "pass descriptor constructors with fields need to be records"+    _ -> error "pass descriptor constructors with fields need to be records"  )  data PassManagerBuilder

@@ -78,8 +78,8 @@ LLVM_HS_FOR_EACH_PASS_WITHOUT_LLVM_C_BINDING(ENUM_CASE) #undef ENUM_CASE -void LLVM_Hs_AddCodeGenPreparePass(LLVMPassManagerRef PM, LLVMTargetMachineRef T) {-	unwrap(PM)->add(createCodeGenPreparePass(unwrap(T)));+void LLVM_Hs_AddCodeGenPreparePass(LLVMPassManagerRef PM) {+	unwrap(PM)->add(createCodeGenPreparePass()); } 	 void LLVM_Hs_AddGlobalValueNumberingPass(LLVMPassManagerRef PM, LLVMBool noLoads) {@@ -112,58 +112,6 @@ 	 void LLVM_Hs_AddSROAPass(LLVMPassManagerRef PM) { 	unwrap(PM)->add(createSROAPass());-}--void LLVM_Hs_AddBasicBlockVectorizePass(-	LLVMPassManagerRef PM,-	unsigned vectorBits,-	LLVMBool vectorizeBools,-	LLVMBool vectorizeInts,-	LLVMBool vectorizeFloats,-	LLVMBool vectorizePointers,-	LLVMBool vectorizeCasts,-	LLVMBool vectorizeMath,-	LLVMBool vectorizeFusedMultiplyAdd,-	LLVMBool vectorizeSelect,-	LLVMBool vectorizeCmp,-	LLVMBool vectorizeGetElementPtr,-	LLVMBool vectorizeMemoryOperations,-	LLVMBool alignedOnly,-	unsigned reqChainDepth,-	unsigned searchLimit,-	unsigned maxCandidatePairsForCycleCheck,-	LLVMBool splatBreaksChain,-	unsigned maxInstructions,-	unsigned maxIterations,-	LLVMBool powerOfTwoLengthsOnly,-	LLVMBool noMemoryOperationBoost,-	LLVMBool fastDependencyAnalysis-) {-	VectorizeConfig vectorizeConfig;-	vectorizeConfig.VectorBits = vectorBits;-	vectorizeConfig.VectorizeBools = vectorizeBools;-	vectorizeConfig.VectorizeInts = vectorizeInts;-	vectorizeConfig.VectorizeFloats = vectorizeFloats;-	vectorizeConfig.VectorizePointers = vectorizePointers;-	vectorizeConfig.VectorizeCasts = vectorizeCasts;-	vectorizeConfig.VectorizeMath = vectorizeMath;-	vectorizeConfig.VectorizeFMA = vectorizeFusedMultiplyAdd;-	vectorizeConfig.VectorizeSelect = vectorizeSelect;-	vectorizeConfig.VectorizeCmp = vectorizeCmp;-	vectorizeConfig.VectorizeGEP = vectorizeGetElementPtr;-	vectorizeConfig.VectorizeMemOps = vectorizeMemoryOperations;-	vectorizeConfig.AlignedOnly = alignedOnly;-	vectorizeConfig.ReqChainDepth = reqChainDepth;-	vectorizeConfig.SearchLimit = searchLimit;-	vectorizeConfig.MaxCandPairsForCycleCheck = maxCandidatePairsForCycleCheck;-	vectorizeConfig.SplatBreaksChain = splatBreaksChain;-	vectorizeConfig.MaxInsts = maxInstructions;-	vectorizeConfig.MaxIter = maxIterations;-	vectorizeConfig.Pow2LenOnly = powerOfTwoLengthsOnly;-	vectorizeConfig.NoMemOpBoost = noMemoryOperationBoost;-	vectorizeConfig.FastDep = fastDependencyAnalysis;	--	unwrap(PM)->add(createBBVectorizePass(vectorizeConfig)); }  void LLVM_Hs_AddGCOVProfilerPass(

@@ -27,7 +27,6 @@  #define LLVM_HS_FOR_EACH_TARGET_OPTION_FLAG(macro)	\ 	macro(PrintMachineCode)																\-	macro(LessPreciseFPMADOption)													\ 	macro(UnsafeFPMath)																		\ 	macro(NoInfsFPMath)																		\ 	macro(NoNaNsFPMath)																		\@@ -37,7 +36,6 @@ 	macro(EnableFastISel)																	\ 	macro(UseInitArray)																		\ 	macro(DisableIntegratedAS)														\-	macro(CompressDebugSections)													\ 	macro(TrapUnreachable)  typedef enum {@@ -45,6 +43,17 @@ 	LLVM_HS_FOR_EACH_TARGET_OPTION_FLAG(ENUM_CASE) #undef ENUM_CASE } LLVM_Hs_TargetOptionFlag;++#define LLVM_HS_FOR_EACH_DEBUG_COMPRESSION_TYPE(macro) \+    macro(None) \+    macro(GNU) \+    macro(Z)++typedef enum {+#define ENUM_CASE(n) LLVM_Hs_DebugCompressionType_ ## n,+    LLVM_HS_FOR_EACH_DEBUG_COMPRESSION_TYPE(ENUM_CASE)+#undef ENUM_CASE+} LLVM_Hs_DebugCompressionType;  #define LLVM_HS_FOR_EACH_FLOAT_ABI(macro)	\ 	macro(Default)																\

@@ -34,6 +34,12 @@ foreign import ccall unsafe "LLVM_Hs_GetTargetOptionFlag" getTargetOptionsFlag ::   Ptr TargetOptions -> TargetOptionFlag -> IO LLVMBool +foreign import ccall unsafe "LLVM_Hs_GetCompressDebugSections" getCompressDebugSections ::+  Ptr TargetOptions -> IO DebugCompressionType++foreign import ccall unsafe "LLVM_Hs_SetCompressDebugSections" setCompressDebugSections ::+  Ptr TargetOptions -> DebugCompressionType -> IO ()+ foreign import ccall unsafe "LLVM_Hs_SetStackAlignmentOverride" setStackAlignmentOverride ::   Ptr TargetOptions -> CUInt -> IO () 

@@ -48,22 +48,22 @@   } } -static LibFunc::Func unwrap(LLVMLibFunc x) {+static LibFunc unwrap(LLVMLibFunc x) {   switch (x) { #define ENUM_CASE(x)                                                           \   case LLVMLibFunc__##x:                                                       \-    return LibFunc::x;+    return LibFunc_ ## x;     LLVM_HS_FOR_EACH_LIB_FUNC(ENUM_CASE) #undef ENUM_CASE   default:-    return LibFunc::Func(0);+    return LibFunc(0);   } } -static LLVMLibFunc wrap(LibFunc::Func x) {+static LLVMLibFunc wrap(LibFunc x) {   switch (x) { #define ENUM_CASE(x)                                                           \-  case LibFunc::x:                                                             \+  case LibFunc_ ## x:                                                             \     return LLVMLibFunc__##x;     LLVM_HS_FOR_EACH_LIB_FUNC(ENUM_CASE) #undef ENUM_CASE@@ -148,6 +148,42 @@   } } +static llvm::DebugCompressionType unwrap(LLVM_Hs_DebugCompressionType compressionType) {+    switch(compressionType) {+#define ENUM_CASE(op)                                \+        case LLVM_Hs_DebugCompressionType_ ## op:    \+            return llvm::DebugCompressionType::op;+        LLVM_HS_FOR_EACH_DEBUG_COMPRESSION_TYPE(ENUM_CASE)+#undef ENUM_CASE+    default:+            assert(false && "Unknown debug compression type");+        return llvm::DebugCompressionType::None;+    }+}++static LLVM_Hs_DebugCompressionType wrap(llvm::DebugCompressionType compressionType) {+    switch(compressionType) {+#define ENUM_CASE(op)                                   \+        case llvm::DebugCompressionType::op:            \+            return LLVM_Hs_DebugCompressionType_ ## op;+        LLVM_HS_FOR_EACH_DEBUG_COMPRESSION_TYPE(ENUM_CASE)+#undef ENUM_CASE+    default: {+            assert(false && "Unknown debug compression type");+            return LLVM_Hs_DebugCompressionType_None;+        }+    }+}++void LLVM_Hs_SetCompressDebugSections(TargetOptions *to,+                                      LLVM_Hs_DebugCompressionType compress) {+    to->CompressDebugSections = unwrap(compress);+}++LLVM_Hs_DebugCompressionType LLVM_Hs_GetCompressDebugSections(TargetOptions* to) {+    return wrap(to->CompressDebugSections);+}+ unsigned LLVM_Hs_GetTargetOptionFlag(TargetOptions *to,                                           LLVM_Hs_TargetOptionFlag f) {   switch (f) {@@ -241,7 +277,7 @@ 	const char *funcName, 	LLVMLibFunc *f ) {-	LibFunc::Func func;+	LibFunc func; 	LLVMBool result = unwrap(l)->getLibFunc(funcName, func); 	*f = wrap(func); 	return result;

@@ -150,3 +150,7 @@ -- | <http://llvm.org/docs/doxygen/html/Core_8cpp.html#a5d3702e198e2373db7e31bb18879efc3> foreign import ccall unsafe "LLVM_Hs_TokenTypeInContext" tokenTypeInContext ::   Ptr Context -> IO (Ptr Type)++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeOther.html#ga7b7c56bf8406c50205fdd410b351ad81>+foreign import ccall unsafe "LLVMLabelTypeInContext" labelTypeInContext ::+  Ptr Context -> IO (Ptr Type)

@@ -5,14 +5,11 @@ import Control.Monad.Trans import Control.Monad.AnyCont -import Foreign.C (CUInt)-import Foreign.Ptr  --import Data.Map (Map)-import qualified Data.Map as Map+import Foreign.Ptr  import qualified LLVM.Internal.FFI.Function as FFI import qualified LLVM.Internal.FFI.PtrHierarchy as FFI+import qualified LLVM.Internal.FFI.Attribute as FFI  import LLVM.Internal.DecodeAST import LLVM.Internal.EncodeAST@@ -23,25 +20,26 @@  import qualified LLVM.AST as A import qualified LLVM.AST.Constant as A-import qualified LLVM.AST.ParameterAttribute as A.PA  +import qualified LLVM.AST.ParameterAttribute as A.PA -getMixedAttributeSet :: Ptr FFI.Function -> DecodeAST MixedAttributeSet-getMixedAttributeSet = decodeM <=< liftIO . FFI.getMixedAttributeSet+getAttributeList :: Ptr FFI.Function -> DecodeAST AttributeList+getAttributeList f = do+  decodeM (FFI.AttrSetDecoder FFI.attributesAtIndex FFI.countParams, f) -setFunctionAttributes :: Ptr FFI.Function -> MixedAttributeSet -> EncodeAST ()-setFunctionAttributes f = (liftIO . FFI.setMixedAttributeSet f) <=< encodeM+setFunctionAttributes :: Ptr FFI.Function -> AttributeList -> EncodeAST ()+setFunctionAttributes f = liftIO . FFI.setAttributeList f <=< encodeM -getParameters :: Ptr FFI.Function -> Map CUInt [A.PA.ParameterAttribute] -> DecodeAST [A.Parameter]+getParameters :: Ptr FFI.Function -> [[A.PA.ParameterAttribute]] -> DecodeAST [A.Parameter] getParameters f attrs = scopeAnyCont $ do   n <- liftIO (FFI.countParams f)   ps <- allocaArray n   liftIO $ FFI.getParams f ps   params <- peekArray n ps-  forM (zip params [0..]) $ \(param, i) -> -    return A.Parameter -       `ap` typeOf param-       `ap` getLocalName param-       `ap` (return $ Map.findWithDefault [] i attrs)+  forM (leftBiasedZip params attrs) $ \(param, pAttrs) ->+    A.Parameter+      <$> typeOf param+      <*> getLocalName param+      <*> (return $ fromMaybe [] pAttrs)    getGC :: Ptr FFI.Function -> DecodeAST (Maybe ShortByteString) getGC f = scopeAnyCont $ decodeM =<< liftIO (FFI.getGC f)

@@ -27,6 +27,7 @@ import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.List.NonEmpty as NonEmpty +import qualified LLVM.Internal.FFI.Attribute as FFI import qualified LLVM.Internal.FFI.PtrHierarchy as FFI import qualified LLVM.Internal.FFI.BinaryOperator as FFI import qualified LLVM.Internal.FFI.Instruction as FFI@@ -54,8 +55,13 @@ import qualified LLVM.AST.Constant as A.C import LLVM.Exception -callInstAttributeSet :: Ptr FFI.Instruction -> DecodeAST MixedAttributeSet-callInstAttributeSet = decodeM <=< liftIO . FFI.getCallSiteAttributeSet+callInstAttributeList :: Ptr FFI.Instruction -> DecodeAST AttributeList+callInstAttributeList instr =+  decodeM+    ( FFI.AttrSetDecoder+        FFI.getCallSiteAttributesAtIndex+        FFI.getCallSiteNumArgOperands+    , instr)  meta :: Ptr FFI.Instruction -> DecodeAST A.InstructionMetadata meta i = do@@ -101,6 +107,7 @@                A.trueDest = trueDest,                A.metadata' = md              }+          _ -> error "Branch instructions should always have 1 or 3 operands"       [instrP|Switch|] -> do         op0 <- op 0         dd <- successor 1@@ -129,12 +136,11 @@         }       [instrP|Invoke|] -> do         cc <- decodeM =<< liftIO (FFI.getCallSiteCallingConvention i)-        attrs <- callInstAttributeSet i+        attrs <- callInstAttributeList i         fv <- liftIO $ FFI.getCallSiteCalledValue i         f <- decodeM fv-        args <- forM [1..nOps-3] $ \j -> do-                  let pAttrs = Map.findWithDefault [] (j-1) (parameterAttributes attrs)-                  return (, pAttrs) `ap` op (j-1)+        args <- forM (leftBiasedZip [1..nOps-3] (parameterAttributes attrs)) $ \(j, pAttrs) ->+                  (, fromMaybe [] pAttrs) <$> op (j-1)         rd <- successor (nOps - 2)         ed <- successor (nOps - 1)         return A.Invoke {@@ -185,6 +191,7 @@           A.defaultUnwindDest = unwindDest,           A.metadata' = md         }+      i -> error ("Unknown terminator instruction kind: " <> show i)  instance EncodeM EncodeAST A.Terminator (Ptr FFI.Instruction) where   encodeM t = scopeAnyCont $ do@@ -240,8 +247,8 @@         let (argvs, argAttrs) = unzip args         (n, argvs) <- encodeM argvs         i <- liftIO $ FFI.buildInvoke builder fv argvs n rb eb s-        attrs <- encodeM $ MixedAttributeSet fAttrs rAttrs (Map.fromList (zip [0..] argAttrs))-        liftIO $ FFI.setCallSiteAttributeSet i attrs+        attrs <- encodeM $ AttributeList fAttrs rAttrs argAttrs+        liftIO $ FFI.setCallSiteAttributeList i attrs         cc <- encodeM cc         liftIO $ FFI.setCallSiteCallingConvention i cc         return $ FFI.upCast i@@ -320,7 +327,10 @@                 "argList" -> ([], [| op 0 |])                 "vector" -> ([], [| op 0 |])                 "element" -> ([], [| op 1 |])-                "index" -> ([], case lrn of "ExtractElement" -> [| op 1 |]; "InsertElement" -> [| op 2 |])+                "index" -> ([], case lrn of+                                  "ExtractElement" -> [| op 1 |]+                                  "InsertElement" -> [| op 2 |]+                                  _ -> [|error "Index fields are only supported for 'ExtractElement' and 'InsertElement': " <> lrn|])                 "mask" -> ([], [| cop 2 |])                 "aggregate" -> ([], [| op 0 |])                 "metadata" -> ([], [| meta i |])@@ -328,14 +338,12 @@                 "fpPredicate" -> ([], [| decodeM =<< liftIO (FFI.getFCmpPredicate i) |])                 "tailCallKind" -> ([], [| decodeM =<< liftIO (FFI.getTailCallKind i) |])                 "callingConvention" -> ([], [| decodeM =<< liftIO (FFI.getCallSiteCallingConvention i) |])-                "attrs" -> ([], [| callInstAttributeSet i |])+                "attrs" -> ([], [| callInstAttributeList i |])                 "returnAttributes" -> (["attrs"], [| return $ returnAttributes $(TH.dyn "attrs") |])                 "f" -> ([], [| liftIO $ FFI.getCallSiteCalledValue i |])                 "function" -> (["f"], [| decodeM $(TH.dyn "f") |])-                "arguments" -> ([], [| forM [1..nOps-1] $ \j -> do-                                         let pAttrs = Map.findWithDefault [] (j-1) (parameterAttributes $(TH.dyn "attrs"))-                                         p <- op (j-1)-                                         return (p, pAttrs) |])+                "arguments" -> ([], [| forM (leftBiasedZip [1..nOps-1] (parameterAttributes $(TH.dyn "attrs"))) $ \(j, pAttrs) ->+                                         (\p -> (p, fromMaybe [] pAttrs)) <$> op (j - 1) |])                 "clauses" ->                   ([], [|do                           nClauses <- liftIO $ FFI.getNumClauses i@@ -387,8 +395,8 @@                                               decodeM =<< liftIO (FFI.getArgOperand i op) |])                 _ -> ([], [| error $ "unrecognized instruction field or depenency thereof: " ++ show s |])           in-          TH.caseE [| n |] [-            TH.match opcodeP (TH.normalB (TH.doE handlerBody)) []+          TH.caseE [| n |] $+            [ TH.match opcodeP (TH.normalB (TH.doE handlerBody)) []             | (lrn, iDef) <- Map.toList ID.instructionDefs,               ID.instructionKind iDef /= ID.Terminator,               let opcodeP = TH.dataToPatQ (const Nothing) (ID.cppOpcode iDef)@@ -407,7 +415,8 @@                                  [ (f,) <$> (TH.varE . TH.mkName . TH.nameBase $ f) | f <- fieldNames ])                         |]                       ]-                ]+            ] +++            [ TH.match TH.wildP (TH.normalB [| error ("Unknown instruction opcode: " <> show n) |]) [] ]          )      instance EncodeM EncodeAST A.Instruction (Ptr FFI.Instruction, EncodeAST ()) where@@ -459,8 +468,8 @@             let (argvs, argAttrs) = unzip args             (n, argvs) <- encodeM argvs             i <- liftIO $ FFI.buildCall builder fv argvs n s-            attrs <- encodeM $ MixedAttributeSet fAttrs rAttrs (Map.fromList (zip [0..] argAttrs))-            liftIO $ FFI.setCallSiteAttributeSet i attrs+            attrs <- encodeM $ AttributeList fAttrs rAttrs argAttrs+            liftIO $ FFI.setCallSiteAttributeList i attrs             tck <- encodeM tck             liftIO $ FFI.setTailCallKind i tck             cc <- encodeM cc@@ -544,9 +553,9 @@             (numArgs, args') <- encodeM args             i <- liftIO $ FFI.buildCatchPad builder catchSwitch' args' numArgs s             return' i-          o -> $(TH.caseE [| o |] [-                   TH.match-                   (TH.recP fullName [ (f,) <$> (TH.varP . TH.mkName . TH.nameBase $ f) | f <- fieldNames ])+          o -> $(TH.caseE [| o |] $+                  [TH.match+                   (TH.recP fullName [ (f,) <$> (TH.varP . TH.mkName . TH.nameBase $ f) | f <- encodeFieldNames ])                    (TH.normalB (TH.doE handlerBody))                    []                    |@@ -559,7 +568,8 @@                      _ -> False,                    let                      TH.RecC fullName (unzip3 -> (fieldNames, _, _)) = findInstrFields name-                     encodeMFields = map TH.nameBase fieldNames List.\\ [ "metadata" ]+                     encodeFieldNames = filter (\f -> TH.nameBase f /= "metadata") fieldNames+                     encodeMFields = map TH.nameBase encodeFieldNames                      handlerBody = ([                        TH.bindS (if s == "fastMathFlags" then TH.tupP [] else TH.varP (TH.mkName s))                            [| encodeM $(TH.dyn s) |] | s <- encodeMFields@@ -570,7 +580,23 @@                         ) |],                        TH.noBindS [| return' $(TH.dyn "i") |]                       ])-                  ]+                  ] +++                  (map (\p -> TH.match p (TH.normalB [|inconsistentCases "Instruction" o|]) [])+                       [[p|A.Alloca{}|],+                        [p|A.ICmp{}|],+                        [p|A.FCmp{}|],+                        [p|A.Phi{}|],+                        [p|A.Call{}|],+                        [p|A.Select{}|],+                        [p|A.VAArg{}|],+                        [p|A.ExtractElement{}|],+                        [p|A.InsertElement{}|],+                        [p|A.ShuffleVector{}|],+                        [p|A.ExtractValue{}|],+                        [p|A.InsertValue{}|],+                        [p|A.LandingPad{}|],+                        [p|A.CatchPad{}|],+                        [p|A.CleanupPad{}|]])                 )          setMD inst (A.metadata o)@@ -585,22 +611,31 @@     w <- if t == A.VoidType then (return A.Do) else (return (A.:=) `ap` getLocalName i)     return $ return w `ap` decodeM i -instance EncodeM EncodeAST a (Ptr FFI.Instruction) => EncodeM EncodeAST (A.Named a) (Ptr FFI.Instruction) where+guardNonVoidType :: (MonadIO m, MonadThrow m) => Ptr FFI.Instruction -> String -> m ()+guardNonVoidType instr expr = do+  ty <- (liftIO . runDecodeAST . typeOf) instr+  case ty of+    A.VoidType -> throwM (EncodeException ("Instruction of type void must not have a name: " ++ expr))+    _ -> return ()++instance (EncodeM EncodeAST a (Ptr FFI.Instruction), Show a) => EncodeM EncodeAST (A.Named a) (Ptr FFI.Instruction) where   encodeM (A.Do o) = encodeM o-  encodeM (n A.:= o) = do+  encodeM assgn@(n A.:= o) = do     i <- encodeM o     let v = FFI.upCast i     n' <- encodeM n     liftIO $ FFI.setValueName v n'     defineLocal n v+    guardNonVoidType i (show assgn)     return i -instance EncodeM EncodeAST a (Ptr FFI.Instruction, EncodeAST ()) => EncodeM EncodeAST (A.Named a) (EncodeAST ()) where+instance (EncodeM EncodeAST a (Ptr FFI.Instruction, EncodeAST ()), Show a) => EncodeM EncodeAST (A.Named a) (EncodeAST ()) where   encodeM (A.Do o) = liftM snd $ (encodeM o :: EncodeAST (Ptr FFI.Instruction, EncodeAST ()))-  encodeM (n A.:= o) = do+  encodeM assgn@(n A.:= o) = do     (i, later) <- encodeM o     let v = FFI.upCast (i :: Ptr FFI.Instruction)     n' <- encodeM n     liftIO $ FFI.setValueName v n'     defineLocal n v+    guardNonVoidType i (show assgn)     return later

@@ -29,6 +29,7 @@   for(p = list; p < list + sizeof(list)/sizeof(list[0]); ++p) { \     hsc_printf("  decodeM (FFI.LibFunc %u) = return LF__%s \n", p->n, p->s); \   } \+  hsc_printf("  decodeM f = error (\"Unknown libfunc: \" <> show f)\n"); \ } } 

@@ -336,7 +336,7 @@          defineGlobal fName f          cc <- encodeM cc          liftIO $ FFI.setFunctionCallingConvention f cc-         setFunctionAttributes f (MixedAttributeSet attrs rAttrs (Map.fromList $ zip [0..] [pa | A.Parameter _ _ pa <- args]))+         setFunctionAttributes f (AttributeList attrs rAttrs [pa | A.Parameter _ _ pa <- args])          setPrefixData f prefix          setSection f (A.G.section g)          setCOMDAT f (A.G.comdat g)@@ -436,7 +436,7 @@     localScope $ do       A.PointerType (A.FunctionType returnType _ isVarArg) _ <- typeOf f       n <- getGlobalName f-      MixedAttributeSet fAttrs rAttrs pAttrs <- getMixedAttributeSet f+      AttributeList fAttrs rAttrs pAttrs <- getAttributeList f       parameters <- getParameters f pAttrs       decodeBlocks <- do         ffiBasicBlocks <-@@ -517,7 +517,7 @@       namedMetadata <- decodeNamedMetadataDefinitions mod       metadata <- getMetadataDefinitions       functionAttributes <- do-        functionAttributes <- gets $ Map.toList . functionAttributeSetIDs+        functionAttributes <- gets $ functionAttributeListIDs         forM functionAttributes $ \(as, gid) ->           A.FunctionAttributes <$> return gid <*> decodeM as       comdats <- gets $ map (uncurry A.COMDAT) . Map.elems . comdats

@@ -95,9 +95,11 @@     flags' <- encodeM flags     FFI.setJITSymbol jitSymbol (FFI.TargetAddress (fromIntegral addr)) flags' -instance MonadIO m => DecodeM m JITSymbol (Ptr FFI.JITSymbol) where+instance (MonadIO m, MonadAnyCont IO m) => DecodeM m JITSymbol (Ptr FFI.JITSymbol) where   decodeM jitSymbol = do-    FFI.TargetAddress addr <- liftIO $ FFI.getAddress jitSymbol+    errMsg <- alloca+    FFI.TargetAddress addr <- liftIO $ FFI.getAddress jitSymbol errMsg+    -- TODO read error message and throw exception     flags <- liftIO $ decodeM =<< FFI.getFlags jitSymbol     return (JITSymbol (fromIntegral addr) flags) 

@@ -1,6 +1,6 @@ module LLVM.Internal.OrcJIT.CompileLayer   ( module LLVM.Internal.OrcJIT.CompileLayer-  , FFI.ModuleSetHandle+  , FFI.ModuleHandle   ) where  import LLVM.Prelude@@ -9,7 +9,6 @@ import Control.Monad.AnyCont import Control.Monad.IO.Class import Data.IORef-import Foreign.Marshal.Array (withArrayLen) import Foreign.Ptr  import LLVM.Internal.Coding@@ -21,7 +20,7 @@  -- | There are two main types of operations provided by instances of 'CompileLayer'. ----- 1. You can add \/ remove modules using 'addModuleSet' \/ 'removeModuleSet'.+-- 1. You can add \/ remove modules using 'addModule' \/ 'removeModuleSet'. -- -- 2. You can search for symbols using 'findSymbol' \/ 'findSymbolIn' in -- the previously added modules.@@ -53,9 +52,9 @@   decodeM symbol  -- | @'findSymbolIn' layer handle symbol exportedSymbolsOnly@ searches for--- @symbol@ in the context of the modules represented by @handle@. If+-- @symbol@ in the context of the module represented by @handle@. If -- @exportedSymbolsOnly@ is 'True' only exported symbols are searched.-findSymbolIn :: CompileLayer l => l -> FFI.ModuleSetHandle -> MangledSymbol -> Bool -> IO JITSymbol+findSymbolIn :: CompileLayer l => l -> FFI.ModuleHandle -> MangledSymbol -> Bool -> IO JITSymbol findSymbolIn compileLayer handle symbol exportedSymbolsOnly = flip runAnyContT return $ do   symbol' <- encodeM symbol   exportedSymbolsOnly' <- encodeM exportedSymbolsOnly@@ -63,41 +62,40 @@     (FFI.findSymbolIn (getCompileLayer compileLayer) handle symbol' exportedSymbolsOnly') FFI.disposeSymbol   decodeM symbol --- | Add a list of modules to the 'CompileLayer'. The 'SymbolResolver' is used--- to resolve external symbols in these modules.+-- | Add a module to the 'CompileLayer'. The 'SymbolResolver' is used+-- to resolve external symbols in the module. ----- /Note:/ This function consumes the modules passed be it and they--- must not be used after calling this method.-addModuleSet :: CompileLayer l => l -> [Module] -> SymbolResolver -> IO FFI.ModuleSetHandle-addModuleSet compileLayer modules resolver = flip runAnyContT return $ do+-- /Note:/ This function consumes the module passed to it and it must+-- not be used after calling this method.+addModule :: CompileLayer l => l -> Module -> SymbolResolver -> IO FFI.ModuleHandle+addModule compileLayer mod resolver = flip runAnyContT return $ do   resolverAct <- encodeM resolver   resolver' <- liftIO $ resolverAct (getCleanups compileLayer)-  modules' <- liftIO $ mapM readModule modules-  liftIO $ mapM_ deleteModule modules-  (moduleCount, modules'') <--    anyContToM $ \f -> withArrayLen modules' $ \n hs -> f (fromIntegral n, hs)+  mod' <- liftIO $ readModule mod+  liftIO $ deleteModule mod+  errMsg <- alloca   liftIO $-    FFI.addModuleSet+    FFI.addModule       (getCompileLayer compileLayer)       (getDataLayout compileLayer)-      modules''-      moduleCount+      mod'       resolver'+      errMsg --- | Remove a set of previously added modules.-removeModuleSet :: CompileLayer l => l -> FFI.ModuleSetHandle -> IO ()-removeModuleSet compileLayer handle =-  FFI.removeModuleSet (getCompileLayer compileLayer) handle+-- | Remove a previously added module.+removeModule :: CompileLayer l => l -> FFI.ModuleHandle -> IO ()+removeModule compileLayer handle =+  FFI.removeModule (getCompileLayer compileLayer) handle --- | 'bracket'-style wrapper around 'addModuleSet' and 'removeModuleSet'.+-- | 'bracket'-style wrapper around 'addModule' and 'removeModule'. ----- /Note:/ This function consumes the modules passed to it and they--- must not be used after calling this method.-withModuleSet :: CompileLayer l => l -> [Module] -> SymbolResolver -> (FFI.ModuleSetHandle -> IO a) -> IO a-withModuleSet compileLayer modules resolver =+-- /Note:/ This function consumes the module passed to it and it must+-- not be used after calling this method.+withModule :: CompileLayer l => l -> Module -> SymbolResolver -> (FFI.ModuleHandle -> IO a) -> IO a+withModule compileLayer mod resolver =   bracket-    (addModuleSet compileLayer modules resolver)-    (removeModuleSet compileLayer)+    (addModule compileLayer mod resolver)+    (removeModule compileLayer)  -- | Dispose of a 'CompileLayer'. This should called when the -- 'CompileLayer' is not needed anymore.

@@ -109,7 +109,7 @@         handleOption FFI.passManagerBuilderSetLoopVectorize loopVectorize         handleOption FFI.passManagerBuilderSetSuperwordLevelParallelismVectorize superwordLevelParallelismVectorize         FFI.passManagerBuilderPopulateModulePassManager b pm-    PassSetSpec ps dl tli tm' -> do+    PassSetSpec ps _ _ tm' -> do       let tm = maybe nullPtr (\(TargetMachine tm) -> tm) tm'       forM_ ps $ \p -> $(         do@@ -123,6 +123,7 @@               (n, fns) = case con of                             TH.RecC n fs -> (n, [ TH.nameBase fn | (fn, _, _) <- fs ])                             TH.NormalC n [] -> (n, [])+                            _ -> error "pass descriptor constructors with fields need to be records"               actions =                  [ TH.bindS (TH.varP . TH.mkName $ fn) [| encodeM $(TH.dyn fn) |] | fn <- fns ]                 ++ [

@@ -20,7 +20,6 @@ import Data.Char import Data.Map (Map) import qualified Data.Map as Map-import Data.Monoid import Foreign.C.String import Foreign.Ptr @@ -75,6 +74,12 @@   (FFI.fpOpFusionModeStrict, TO.FloatingPointOperationFusionStrict)  ] +genCodingInstance[t| TO.DebugCompressionType |] ''FFI.DebugCompressionType [+  (FFI.debugCompressionTypeNone, TO.CompressNone),+  (FFI.debugCompressionTypeGNU, TO.CompressGNU),+  (FFI.debugCompressionTypeZ, TO.CompressZ)+  ]+ -- | <http://llvm.org/doxygen/classllvm_1_1Target.html> newtype Target = Target (Ptr FFI.Target) @@ -128,7 +133,6 @@ pokeTargetOptions hOpts (TargetOptions cOpts) = do   mapM_ (\(c, ha) -> FFI.setTargetOptionFlag cOpts c =<< encodeM (ha hOpts)) [     (FFI.targetOptionFlagPrintMachineCode, TO.printMachineCode),-    (FFI.targetOptionFlagLessPreciseFPMADOption, TO.lessPreciseFloatingPointMultiplyAddOption),     (FFI.targetOptionFlagUnsafeFPMath, TO.unsafeFloatingPointMath),     (FFI.targetOptionFlagNoInfsFPMath, TO.noInfinitiesFloatingPointMath),     (FFI.targetOptionFlagNoNaNsFPMath, TO.noNaNsFloatingPointMath),@@ -138,12 +142,12 @@     (FFI.targetOptionFlagEnableFastISel, TO.enableFastInstructionSelection),     (FFI.targetOptionFlagUseInitArray, TO.useInitArray),     (FFI.targetOptionFlagDisableIntegratedAS, TO.disableIntegratedAssembler),-    (FFI.targetOptionFlagCompressDebugSections, TO.compressDebugSections),     (FFI.targetOptionFlagTrapUnreachable, TO.trapUnreachable)    ]   FFI.setStackAlignmentOverride cOpts =<< encodeM (TO.stackAlignmentOverride hOpts)   FFI.setFloatABIType cOpts =<< encodeM (TO.floatABIType hOpts)   FFI.setAllowFPOpFusion cOpts =<< encodeM (TO.allowFloatingPointOperationFusion hOpts)+  FFI.setCompressDebugSections cOpts =<< encodeM (TO.compressDebugSections hOpts)  -- | get all target options peekTargetOptions :: TargetOptions -> IO TO.Options@@ -151,8 +155,6 @@   let gof = decodeM <=< FFI.getTargetOptionsFlag tOpts   printMachineCode     <- gof FFI.targetOptionFlagPrintMachineCode-  lessPreciseFloatingPointMultiplyAddOption-    <- gof FFI.targetOptionFlagLessPreciseFPMADOption   unsafeFloatingPointMath     <- gof FFI.targetOptionFlagUnsafeFPMath   noInfinitiesFloatingPointMath@@ -171,8 +173,7 @@     <- gof FFI.targetOptionFlagUseInitArray   disableIntegratedAssembler     <- gof FFI.targetOptionFlagDisableIntegratedAS-  compressDebugSections-    <- gof FFI.targetOptionFlagCompressDebugSections+  compressDebugSections <- decodeM =<< FFI.getCompressDebugSections tOpts   trapUnreachable     <- gof FFI.targetOptionFlagTrapUnreachable   stackAlignmentOverride <- decodeM =<< FFI.getStackAlignmentOverride tOpts@@ -229,7 +230,7 @@  -- | get the 'TargetLowering' of a 'TargetMachine' getTargetLowering :: TargetMachine -> IO TargetLowering-getTargetLowering (TargetMachine tm) = TargetLowering <$> error "FIXME: getTargetLowering" -- FFI.getTargetLowering tm+getTargetLowering (TargetMachine _) = TargetLowering <$> error "FIXME: getTargetLowering" -- FFI.getTargetLowering tm  -- | Initialize the native target. This function is called automatically in these Haskell bindings -- when creating an 'LLVM.ExecutionEngine.ExecutionEngine' which will require it, and so it should

@@ -103,6 +103,7 @@       A.NamedTypeReference n -> lookupNamedType n       A.MetadataType -> liftIO $ FFI.metadataTypeInContext context       A.TokenType -> liftIO $ FFI.tokenTypeInContext context+      A.LabelType -> liftIO $ FFI.labelTypeInContext context  instance DecodeM DecodeAST A.Type (Ptr FFI.Type) where   decodeM t = scopeAnyCont $ do

@@ -15,7 +15,6 @@ import LLVM.Internal.Coding import LLVM.Internal.DecodeAST import LLVM.Internal.Type () -import LLVM.Internal.Constant ()   import qualified LLVM.AST.Type as A 

@@ -2,10 +2,10 @@     -- * CompileLayer     CompileLayer,     -- ** Add/remove modules-    ModuleSetHandle,-    addModuleSet,-    removeModuleSet,-    withModuleSet,+    ModuleHandle,+    addModule,+    removeModule,+    withModule,     -- ** Search for symbols     findSymbol,     findSymbolIn,

@@ -17,11 +17,17 @@   | FloatingPointOperationFusionStrict   deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic) +-- | <https://llvm.org/doxygen/namespacellvm.html#aa100a124c9d33561b0950011928aae00>+data DebugCompressionType+  = CompressNone -- ^ No compression+  | CompressGNU -- ^ zlib-gnu style compression+  | CompressZ -- ^ zlib style compression+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic)+ -- | The options of a 'LLVM.Target.TargetOptions' -- <http://llvm.org/doxygen/classllvm_1_1TargetOptions.html> data Options = Options {   printMachineCode :: Bool,-  lessPreciseFloatingPointMultiplyAddOption :: Bool,   unsafeFloatingPointMath :: Bool,   noInfinitiesFloatingPointMath :: Bool,   noNaNsFloatingPointMath :: Bool,@@ -31,7 +37,7 @@   enableFastInstructionSelection :: Bool,   useInitArray :: Bool,   disableIntegratedAssembler :: Bool,-  compressDebugSections :: Bool,+  compressDebugSections :: DebugCompressionType,   trapUnreachable :: Bool,   stackAlignmentOverride :: Word32,   floatABIType :: FloatABI,

@@ -79,30 +79,6 @@   | StripSymbols { onlyDebugInfo :: Bool }    -- here begin the vectorization passes-  | BasicBlockVectorize { -      vectorBits :: Word,-      vectorizeBools :: Bool,-      vectorizeInts :: Bool,-      vectorizeFloats :: Bool,-      vectorizePointers :: Bool,-      vectorizeCasts :: Bool,-      vectorizeMath :: Bool,-      vectorizeFusedMultiplyAdd :: Bool,-      vectorizeSelect :: Bool,-      vectorizeCmp :: Bool,-      vectorizeGetElementPtr :: Bool,-      vectorizeMemoryOperations :: Bool,-      alignedOnly :: Bool,-      requiredChainDepth :: Word,-      searchLimit :: Word,-      maxCandidatePairsForCycleCheck :: Word,-      splatBreaksChain :: Bool,-      maxInstructions :: Word,-      maxIterations :: Word,-      powerOfTwoLengthsOnly :: Bool,-      noMemoryOperationBoost :: Bool,-      fastDependencyAnalysis :: Bool-    }   | LoopVectorize {       noUnrolling :: Bool,       alwaysVectorize :: Bool@@ -132,36 +108,6 @@ defaultLoopVectorize = LoopVectorize {     noUnrolling = False,     alwaysVectorize = True-  }---- | Defaults for the 'BasicBlockVectorize' pass - copied from the C++ code to keep these defaults--- constant. (The C++ defaults are modifiable through global objects used for command-line processing,--- in a design apparently oblivious to uses of LLVM besides the standard command-line tools).-defaultVectorizeBasicBlocks :: Pass-defaultVectorizeBasicBlocks = BasicBlockVectorize {-    vectorBits = 128,-    vectorizeBools = True,-    vectorizeInts = True,-    vectorizeFloats = True,-    vectorizePointers = True,-    vectorizeCasts = True,-    vectorizeMath = True,-    vectorizeFusedMultiplyAdd = True,-    vectorizeSelect = True,-    vectorizeCmp = True,-    vectorizeGetElementPtr = True,-    vectorizeMemoryOperations = True,-    alignedOnly = True,--    requiredChainDepth = 6,-    searchLimit = 400,-    maxCandidatePairsForCycleCheck = 200,-    splatBreaksChain = False,-    maxInstructions = 500,-    maxIterations = 0,-    powerOfTwoLengthsOnly = False,-    noMemoryOperationBoost = False,-    fastDependencyAnalysis = False   }  -- | See <http://gcc.gnu.org/viewcvs/gcc/trunk/gcc/gcov-io.h?view=markup>.

@@ -56,6 +56,6 @@    ("spir_kernel", CC.SPIR_KERNEL),    ("intel_ocl_bicc", CC.Intel_OCL_BI),    ("x86_64_sysvcc", CC.X86_64_SysV),-   ("x86_64_win64cc", CC.X86_64_Win64)+   ("win64cc", CC.Win64)   ]  ]

@@ -19,6 +19,7 @@ import Data.Bits import Data.List import Text.Show.Pretty+import Control.Monad.IO.Class (liftIO) import Prelude import qualified Data.ByteString.Short                    as B @@ -62,6 +63,7 @@     , return InaccessibleMemOnly     , return InaccessibleMemOrArgMemOnly     , return SafeStack+    , return Speculatable     ]    shrink = \case@@ -78,12 +80,13 @@   testGroup "FunctionAttribute"     [ testProperty "round-trip"  $ \attr ->         ioProperty $ withContext $ \ctx  -> do-          x <- runEncodeAST ctx (encodeM [attr] :: EncodeAST FFI.FunctionAttributeSet)-          y <- runDecodeAST (decodeM x :: DecodeAST [FunctionAttribute])+          attr' <- runEncodeAST ctx $ do+            attrSet <- encodeM [attr] :: EncodeAST FFI.FunctionAttributeSet+            liftIO (runDecodeAST (decodeM attrSet :: DecodeAST [FunctionAttribute]))           return $ counterexample (unlines [ "expected: " ++ ppShow [attr]-                                           , "but got:  " ++ ppShow y+                                           , "but got:  " ++ ppShow attr'                                            ])-                                  ([attr] == y)+                                  ([attr] == attr')     ]  

@@ -288,7 +288,7 @@            Load {              volatile = False,              address = a 2,-             maybeAtomicity = Just (CrossThread, Acquire),+             maybeAtomicity = Just (System, Acquire),              alignment = 1,              metadata = []             },@@ -301,7 +301,7 @@              alignment = 1,              metadata = []             },-           "load atomic i32, i32* %2 singlethread monotonic, align 1"),+           "load atomic i32, i32* %2 syncscope(\"singlethread\") monotonic, align 1"),           ("GEP",            GetElementPtr {              inBounds = False,@@ -324,7 +324,7 @@              address = a 2,              expected = a 0,              replacement = a 0,-             atomicity = (CrossThread, Monotonic),+             atomicity = (System, Monotonic),              failureMemoryOrdering = Monotonic,              metadata = []             },@@ -335,7 +335,7 @@              rmwOperation = RMWOp.UMax,              address = a 2,              value = a 0,-             atomicity = (CrossThread, Release),+             atomicity = (System, Release),              metadata = []            },            "atomicrmw umax i32* %2, i32 %0 release"),@@ -559,7 +559,7 @@           "store i32 %0, i32* %2"),          ("fence",           Do $ Fence {-            atomicity = (CrossThread, Acquire),+            atomicity = (System, Acquire),             metadata = []           },           "fence acquire"),

@@ -124,7 +124,13 @@           tailCallKind = Nothing,           callingConvention = CC.C,           returnAttributes = [],-          function = Right (ConstantOperand (C.GlobalReference (FunctionType i32 [i32, ptr (ptr i8)] False) (Name "foo"))),+          function = Right+            (ConstantOperand+              (C.GlobalReference+                 (PointerType+                    { pointerReferent = FunctionType i32 [i128] False+                    , pointerAddrSpace = AddrSpace 0})+                 (Name "foo"))),           arguments = [            (ConstantOperand (C.Int 128 9491828328), [])           ],

@@ -289,7 +289,7 @@    testCase "moduleAST" $ withContext $ \context -> do     ast <- withModuleFromLLVMAssembly' context handString moduleAST-    ast @?= handAST,+    assertEqPretty ast handAST,        testCase "withModuleFromAST" $ withContext $ \context -> do     s <- withModuleFromAST context handAST moduleLLVMAssembly

@@ -174,38 +174,63 @@         FunctionAttributes (A.GroupID 0) [A.NoUnwind, A.ReadNone, A.UWTable]        ], -    testCase "BasicBlockVectorization" $ do+    testCase "SLPVectorization" $ do       let+        fadd op0 op1 =+          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)+        extractElement vec index' =+          ExtractElement { vector = vec, index = index', metadata = [] }+        insertElement vec el i =+          InsertElement { vector = vec, element = el, index = i, metadata = [] }         mIn = Module "<string>" "<string>" Nothing Nothing [           GlobalDefinition $ functionDefaults {-           G.returnType = double,-            G.name = Name "foo",+           G.returnType = doubleVec,+            G.name = Name "buildVector_add_2f64",             G.parameters = ([-              Parameter double (Name (l <> n)) []-                | l <- [ "a", "b" ], n <- ["1", "2"]+              Parameter doubleVec n []+                | n <- [ "a", "b" ]              ], False),             G.basicBlocks = [-              BasicBlock (UnName 0) ([-                Name (l <> n) := op NoFastMathFlags (LocalReference double (Name (o1 <> n))) (LocalReference double (Name (o2 <> n))) []-                | (l, op, o1, o2) <- [-                   ("x", FSub, "a", "b"),-                   ("y", FMul, "x", "a"),-                   ("z", FAdd, "y", "b")],-                  n <- ["1", "2"]-               ] ++ [-                Name "r" := FMul NoFastMathFlags (LocalReference double (Name "z1")) (LocalReference double (Name "z2")) []-              ]) (Do $ Ret (Just (LocalReference double (Name "r"))) [])+              BasicBlock (UnName 0)+                ["a0" := extractElement (LocalReference doubleVec "a") (constInt 0),+                 "a1" := extractElement (LocalReference doubleVec "a") (constInt 1),+                 "b0" := extractElement (LocalReference doubleVec "b") (constInt 0),+                 "b1" := extractElement (LocalReference doubleVec "b") (constInt 1),+                 "c0" := fadd (LocalReference double "a0") (LocalReference double "b0"),+                 "c1" := fadd (LocalReference double "a1") (LocalReference double "b1"),+                 "r0" := insertElement undef (LocalReference double "c0") (constInt 0),+                 "r1" := insertElement (LocalReference doubleVec "r0") (LocalReference double "c1") (constInt 1)+                ]+                (Do (Ret (Just (LocalReference doubleVec "r1")) []))              ]           }          ]       mOut <- optimize (defaultPassSetSpec {                     transforms = [-                     T.defaultVectorizeBasicBlocks { T.requiredChainDepth = 3 },-                     T.InstructionCombining, +                     T.SuperwordLevelParallelismVectorize,+                     T.InstructionCombining,                      T.GlobalValueNumbering False                     ] }) mIn-      isVectory mOut,-      +      mOut @?=+        Module "<string>" "<string>" Nothing Nothing [+            GlobalDefinition $ functionDefaults {+             G.returnType = doubleVec,+              G.name = Name "buildVector_add_2f64",+              G.parameters = ([+                Parameter doubleVec n []+                  | n <- [ "a", "b" ]+               ], False),+              G.basicBlocks = [+                BasicBlock (UnName 0)+                  [UnName 1 := fadd (LocalReference doubleVec "a") (LocalReference doubleVec "b")]+                  (Do (Ret (Just (LocalReference doubleVec (UnName 1))) []))+               ]+            }+           ],+     testCase "LoopVectorize" $ do       let         mIn = @@ -237,7 +262,7 @@                       (ConstantOperand (C.Int 64 0), UnName 0),                       (LocalReference i64 (Name "indvars.iv.next"), Name ".lr.ph")                      ] [],-                    UnName 2 := GetElementPtr True (ConstantOperand (C.GlobalReference (A.T.ArrayType 2048 i32) (Name "a"))) [ +                    UnName 2 := GetElementPtr True (ConstantOperand (C.GlobalReference (PointerType (A.T.ArrayType 2048 i32) (AddrSpace 0)) (Name "a"))) [                       ConstantOperand (C.Int 64 0),                       (LocalReference i64 (Name "indvars.iv"))                      ] [],

@@ -72,16 +72,16 @@           withObjectLinkingLayer $ \linkingLayer ->             withIRCompileLayer linkingLayer tm $ \compileLayer -> do               testFunc <- mangleSymbol compileLayer "testFunc"-              withModuleSet+              withModule                 compileLayer-                [mod]+                mod                 (SymbolResolver (resolver testFunc compileLayer) nullResolver) $-                \moduleSet -> do+                \moduleHandle -> do                   mainSymbol <- mangleSymbol compileLayer "main"                   JITSymbol mainFn _ <- findSymbol compileLayer mainSymbol True                   result <- mkMain (castPtrToFunPtr (wordPtrToPtr mainFn))                   result @?= 42-                  JITSymbol mainFn _ <- findSymbolIn compileLayer moduleSet mainSymbol True+                  JITSymbol mainFn _ <- findSymbolIn compileLayer moduleHandle mainSymbol True                   result <- mkMain (castPtrToFunPtr (wordPtrToPtr mainFn))                   result @?= 42, @@ -93,11 +93,11 @@             withIRCompileLayer linkingLayer tm $ \compileLayer -> do               withIRTransformLayer compileLayer tm (moduleTransform passmanagerSuccessful) $ \compileLayer -> do                 testFunc <- mangleSymbol compileLayer "testFunc"-                withModuleSet+                withModule                   compileLayer-                  [mod]+                  mod                   (SymbolResolver (resolver testFunc compileLayer) nullResolver) $-                  \moduleSet -> do+                  \moduleHandle -> do                     mainSymbol <- mangleSymbol compileLayer "main"                     JITSymbol mainFn _ <- findSymbol compileLayer mainSymbol True                     result <- mkMain (castPtrToFunPtr (wordPtrToPtr mainFn))@@ -114,11 +114,11 @@                 withJITCompileCallbackManager triple Nothing $ \callbackMgr ->                   withCompileOnDemandLayer baseLayer tm (\x -> return [x]) callbackMgr stubsMgr False $ \compileLayer -> do                     testFunc <- mangleSymbol compileLayer "testFunc"-                    withModuleSet+                    withModule                       compileLayer-                      [mod]+                      mod                       (SymbolResolver (resolver testFunc compileLayer) nullResolver) $-                      \moduleSet -> do+                      \moduleHandle -> do                         mainSymbol <- mangleSymbol compileLayer "main"                         JITSymbol mainFn _ <- findSymbol compileLayer mainSymbol True                         result <- mkMain (castPtrToFunPtr (wordPtrToPtr mainFn))

@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings #-}+module LLVM.Test.Regression+  ( tests+  ) where++import           Test.Tasty+import           Test.Tasty.HUnit++import qualified LLVM.AST as AST+import           LLVM.AST hiding (Module)+import           LLVM.AST.Constant+import           LLVM.AST.Global+import           LLVM.AST.Type++import           LLVM.Context+import           LLVM.Exception+import           LLVM.Module++import           Control.Exception++example1 :: AST.Module+example1 =+  defaultModule+  { moduleDefinitions =+      [ GlobalDefinition+          functionDefaults+          { name = "test"+          , returnType = void+          , basicBlocks =+              [ BasicBlock+                  "entry"+                  [ UnName 0 := Alloca i32 Nothing 0 []+                  , UnName 1 :=+                    Store+                      False+                      (LocalReference (ptr i32) (UnName 0))+                      (ConstantOperand (Int 32 42))+                      Nothing+                      0+                      []+                  ]+                  (Do $ Ret Nothing [])+              ]+          }+      ]+  }++example2 :: AST.Module+example2 =+  defaultModule+  { moduleDefinitions =+      [ GlobalDefinition+          functionDefaults+          { name = "test"+          , returnType = void+          , basicBlocks =+              [ BasicBlock+                  "entry"+                  [ UnName 0 :=+                    Alloca (ptr $ FunctionType void [] False) Nothing 0 []+                  , Do $+                    Store+                      False+                      (LocalReference+                         (ptr $ ptr $ FunctionType void [] False)+                         (UnName 0))+                      (ConstantOperand $+                       GlobalReference (FunctionType void [] False) "test")+                      Nothing+                      0+                      []+                  ]+                  (Do $ Ret Nothing [])+              ]+          }+      ]+  }++shouldThrowEncodeException :: AST.Module -> String -> IO ()+shouldThrowEncodeException ast errMsg = do+  result <- try $ withContext $ \context -> do+    withModuleFromAST context ast (\_ -> return ())+  case result of+    Left (EncodeException actualErrMsg) -> actualErrMsg @?= errMsg+    Right _ -> assertFailure ("Expected serialization to fail with: \"" ++ errMsg ++ "\"")++tests :: TestTree+tests =+  testGroup+    "Regression"+    [ testCase+        "no named voids"+        (example1 `shouldThrowEncodeException`+         "Instruction of type void must not have a name: UnName 1 := Store {volatile = False, address = LocalReference (PointerType {pointerReferent = IntegerType {typeBits = 32}, pointerAddrSpace = AddrSpace 0}) (UnName 0), value = ConstantOperand (Int {integerBits = 32, integerValue = 42}), maybeAtomicity = Nothing, alignment = 0, metadata = []}")+    , 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}")+    ]

@@ -36,7 +36,6 @@ instance Arbitrary Options where   arbitrary = do     printMachineCode <- arbitrary-    lessPreciseFloatingPointMultiplyAddOption <- arbitrary     unsafeFloatingPointMath <- arbitrary     noInfinitiesFloatingPointMath <- arbitrary     noNaNsFloatingPointMath <- arbitrary@@ -53,6 +52,9 @@     allowFloatingPointOperationFusion <- arbitrary     return Options { .. } +instance Arbitrary DebugCompressionType where+  arbitrary = elements [CompressNone, CompressGNU, CompressZ]+ arbitraryASCIIString :: Gen String #if MIN_VERSION_QuickCheck(2,10,0) arbitraryASCIIString = getASCIIString <$> arbitrary@@ -70,7 +72,7 @@        withTargetOptions $ \to -> do          pokeTargetOptions options to          options' <- peekTargetOptions to-         return $ options == options'+         return $ options === options'    ],   testGroup "LibraryFunction" [     testGroup "set-get" [

@@ -19,6 +19,7 @@ import qualified LLVM.Test.Optimization as Optimization import qualified LLVM.Test.OrcJIT as OrcJIT import qualified LLVM.Test.Target as Target+import qualified LLVM.Test.Regression as Regression  tests = testGroup "llvm-hs" [     CallingConvention.tests,@@ -37,5 +38,6 @@     Analysis.tests,     Linking.tests,     Instrumentation.tests,-    ObjectCode.tests+    ObjectCode.tests,+    Regression.tests   ]

@@ -1,11 +1,6 @@-{-# LANGUAGE OverloadedStrings #-} import Test.Tasty import qualified LLVM.Test.Tests as LLVM import LLVM.CommandLine -main = do-  parseCommandLineOptions [-    "test",-    "-bb-vectorize-ignore-target-info"-   ] Nothing-  defaultMain LLVM.tests+main :: IO ()+main = defaultMain LLVM.tests