diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 } } } diff --git a/llvm-hs.cabal b/llvm-hs.cabal --- a/llvm-hs.cabal +++ b/llvm-hs.cabal @@ -1,5 +1,5 @@ name: llvm-hs -version: 4.2.0 +version: 5.0.0 license: BSD3 license-file: LICENSE author: Anthony Cowley, Stephen Diehl, Moritz Kiefer , 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 diff --git a/src/LLVM/Internal/Atomicity.hs b/src/LLVM/Internal/Atomicity.hs --- a/src/LLVM/Internal/Atomicity.hs +++ b/src/LLVM/Internal/Atomicity.hs @@ -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 diff --git a/src/LLVM/Internal/Attribute.hs b/src/LLVM/Internal/Attribute.hs --- a/src/LLVM/Internal/Attribute.hs +++ b/src/LLVM/Internal/Attribute.hs @@ -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)) diff --git a/src/LLVM/Internal/CallingConvention.hs b/src/LLVM/Internal/CallingConvention.hs --- a/src/LLVM/Internal/CallingConvention.hs +++ b/src/LLVM/Internal/CallingConvention.hs @@ -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) diff --git a/src/LLVM/Internal/Coding.hs b/src/LLVM/Internal/Coding.hs --- a/src/LLVM/Internal/Coding.hs +++ b/src/LLVM/Internal/Coding.hs @@ -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) diff --git a/src/LLVM/Internal/Constant.hs b/src/LLVM/Internal/Constant.hs --- a/src/LLVM/Internal/Constant.hs +++ b/src/LLVM/Internal/Constant.hs @@ -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 diff --git a/src/LLVM/Internal/DecodeAST.hs b/src/LLVM/Internal/DecodeAST.hs --- a/src/LLVM/Internal/DecodeAST.hs +++ b/src/LLVM/Internal/DecodeAST.hs @@ -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' diff --git a/src/LLVM/Internal/EncodeAST.hs b/src/LLVM/Internal/EncodeAST.hs --- a/src/LLVM/Internal/EncodeAST.hs +++ b/src/LLVM/Internal/EncodeAST.hs @@ -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 () diff --git a/src/LLVM/Internal/ExecutionEngine.hs b/src/LLVM/Internal/ExecutionEngine.hs --- a/src/LLVM/Internal/ExecutionEngine.hs +++ b/src/LLVM/Internal/ExecutionEngine.hs @@ -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 -> diff --git a/src/LLVM/Internal/FFI/Attribute.h b/src/LLVM/Internal/FFI/Attribute.h --- a/src/LLVM/Internal/FFI/Attribute.h +++ b/src/LLVM/Internal/FFI/Attribute.h @@ -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) \ diff --git a/src/LLVM/Internal/FFI/Attribute.hs b/src/LLVM/Internal/FFI/Attribute.hs --- a/src/LLVM/Internal/FFI/Attribute.hs +++ b/src/LLVM/Internal/FFI/Attribute.hs @@ -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)) diff --git a/src/LLVM/Internal/FFI/AttributeC.cpp b/src/LLVM/Internal/FFI/AttributeC.cpp --- a/src/LLVM/Internal/FFI/AttributeC.cpp +++ b/src/LLVM/Internal/FFI/AttributeC.cpp @@ -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::iterator b = as.begin(slot), e = as.end(slot); - *length = e - b; - return reinterpret_cast(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 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(reinterpret_cast(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(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; } } - } diff --git a/src/LLVM/Internal/FFI/AttributeC.hpp b/src/LLVM/Internal/FFI/AttributeC.hpp --- a/src/LLVM/Internal/FFI/AttributeC.hpp +++ b/src/LLVM/Internal/FFI/AttributeC.hpp @@ -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(&asi); -} - -inline const AttributeSetImpl *wrap(AttributeSet as) { - return *reinterpret_cast(&as); -} - -inline Attribute unwrap(const AttributeImpl *ai) { - return *reinterpret_cast(&ai); -} - -inline const AttributeImpl *wrap(Attribute a) { - return *reinterpret_cast(&a); -} +typedef AttributeSet *LLVMAttributeSetRef; +typedef AttributeList *LLVMAttributeListRef; #endif diff --git a/src/LLVM/Internal/FFI/Builder.hs b/src/LLVM/Internal/FFI/Builder.hs --- a/src/LLVM/Internal/FFI/Builder.hs +++ b/src/LLVM/Internal/FFI/Builder.hs @@ -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) diff --git a/src/LLVM/Internal/FFI/BuilderC.cpp b/src/LLVM/Internal/FFI/BuilderC.cpp --- a/src/LLVM/Internal/FFI/BuilderC.cpp +++ b/src/LLVM/Internal/FFI/BuilderC.cpp @@ -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); } diff --git a/src/LLVM/Internal/FFI/CallingConvention.h b/src/LLVM/Internal/FFI/CallingConvention.h --- a/src/LLVM/Internal/FFI/CallingConvention.h +++ b/src/LLVM/Internal/FFI/CallingConvention.h @@ -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, diff --git a/src/LLVM/Internal/FFI/Cleanup.hs b/src/LLVM/Internal/FFI/Cleanup.hs --- a/src/LLVM/Internal/FFI/Cleanup.hs +++ b/src/LLVM/Internal/FFI/Cleanup.hs @@ -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))) [] ] diff --git a/src/LLVM/Internal/FFI/Constant.hs b/src/LLVM/Internal/FFI/Constant.hs --- a/src/LLVM/Internal/FFI/Constant.hs +++ b/src/LLVM/Internal/FFI/Constant.hs @@ -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 diff --git a/src/LLVM/Internal/FFI/ErrorHandling.cpp b/src/LLVM/Internal/FFI/ErrorHandling.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/ErrorHandling.cpp @@ -0,0 +1,8 @@ +#include "LLVM/Internal/FFI/ErrorHandling.hpp" +#include + +void reportFatalError(const std::string &errorMsg) { + std::cerr << "LLVM-HS ERROR at " << __FILE__ << ":" << __LINE__ << ": " + << errorMsg << "\n "; + exit(1); +} diff --git a/src/LLVM/Internal/FFI/ErrorHandling.hpp b/src/LLVM/Internal/FFI/ErrorHandling.hpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/ErrorHandling.hpp @@ -0,0 +1,7 @@ +#ifndef __LLVM_INTERNAL_FFI__ANALYSIS__H__ +#define __LLVM_INTERNAL_FFI__ANALYSIS__H__ +#include + +[[noreturn]] void reportFatalError(const std::string &errorMsg); + +#endif diff --git a/src/LLVM/Internal/FFI/Function.hs b/src/LLVM/Internal/FFI/Function.hs --- a/src/LLVM/Internal/FFI/Function.hs +++ b/src/LLVM/Internal/FFI/Function.hs @@ -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) diff --git a/src/LLVM/Internal/FFI/FunctionC.cpp b/src/LLVM/Internal/FFI/FunctionC.cpp --- a/src/LLVM/Internal/FFI/FunctionC.cpp +++ b/src/LLVM/Internal/FFI/FunctionC.cpp @@ -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(f)->getAttributes()); -} - -void LLVM_Hs_SetFunctionMixedAttributeSet(LLVMValueRef f, AttributeSetImpl *asi) { - unwrap(f)->setAttributes(unwrap(asi)); +void LLVM_Hs_SetFunctionAttributeList(LLVMValueRef f, + LLVMAttributeListRef attrs) { + unwrap(f)->setAttributes(*attrs); } LLVMBool LLVM_Hs_HasFunctionPrefixData(LLVMValueRef f) { - return unwrap(f)->hasPrefixData(); + return unwrap(f)->hasPrefixData(); } LLVMValueRef LLVM_Hs_GetFunctionPrefixData(LLVMValueRef f) { - return wrap(unwrap(f)->getPrefixData()); + return wrap(unwrap(f)->getPrefixData()); } void LLVM_Hs_SetFunctionPrefixData(LLVMValueRef f, LLVMValueRef p) { - unwrap(f)->setPrefixData(unwrap(p)); + unwrap(f)->setPrefixData(unwrap(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(fn)->setPersonalityFn(personalityFn == nullptr ? - nullptr : unwrap(personalityFn)); + unwrap(fn)->setPersonalityFn( + personalityFn == nullptr ? nullptr : unwrap(personalityFn)); } +LLVMAttributeSetRef LLVM_Hs_FunctionAttributesAtIndex(LLVMValueRef fn, + LLVMAttributeIndex idx) { + return new AttributeSet( + unwrap(fn)->getAttributes().getAttributes(idx)); +} } diff --git a/src/LLVM/Internal/FFI/Instruction.h b/src/LLVM/Internal/FFI/Instruction.h --- a/src/LLVM/Internal/FFI/Instruction.h +++ b/src/LLVM/Internal/FFI/Instruction.h @@ -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 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; diff --git a/src/LLVM/Internal/FFI/Instruction.hs b/src/LLVM/Internal/FFI/Instruction.hs --- a/src/LLVM/Internal/FFI/Instruction.hs +++ b/src/LLVM/Internal/FFI/Instruction.hs @@ -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 diff --git a/src/LLVM/Internal/FFI/InstructionC.cpp b/src/LLVM/Internal/FFI/InstructionC.cpp --- a/src/LLVM/Internal/FFI/InstructionC.cpp +++ b/src/LLVM/Internal/FFI/InstructionC.cpp @@ -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(val)->getFastMathFlags()); } -LLVMValueRef LLVM_Hs_GetCallSiteCalledValue(LLVMValueRef i) { - return wrap(CallSite(unwrap(i)).getCalledValue()); -} - -const AttributeSetImpl *LLVM_Hs_GetCallSiteAttributeSet(LLVMValueRef i) { - return wrap(CallSite(unwrap(i)).getAttributes()); -} - -void LLVM_Hs_SetCallSiteAttributeSet(LLVMValueRef i, const AttributeSetImpl *asi) { - CallSite(unwrap(i)).setAttributes(unwrap(asi)); +void LLVM_Hs_CallSiteSetAttributeList(LLVMValueRef i, LLVMAttributeListRef attrs) { + CallSite(unwrap(i)).setAttributes(*attrs); } unsigned LLVM_Hs_GetCallSiteCallingConvention(LLVMValueRef i) { @@ -97,6 +89,11 @@ CallSite(unwrap(i)).setCallingConv(llvm::CallingConv::ID(cc)); } +LLVMAttributeSetRef LLVM_Hs_CallSiteAttributesAtIndex(LLVMValueRef i, LLVMAttributeIndex idx) { + auto cs = CallSite(unwrap(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(i)->getOpcode()) { -#define ENUM_CASE(n,s) case Instruction::n: return wrap(unwrap(i)->getSynchScope()); +#define ENUM_CASE(n,s) case Instruction::n: return wrap(unwrap(i)->getSyncScopeID()); LLVM_HS_FOR_EACH_ATOMIC_INST(ENUM_CASE) #undef ENUM_CASE default: return LLVMSynchronizationScope(0); @@ -233,8 +230,8 @@ ) { SwitchInst *s = unwrap(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(v); for(unsigned i=0; i != ib->getNumDestinations(); ++i, ++dests) *dests = wrap(ib->getDestination(i)); -} - -inline Metadata **unwrap(LLVMMetadataRef *vals) { - return reinterpret_cast(vals); } void LLVM_Hs_SetMetadata(LLVMValueRef inst, unsigned kindID, LLVMMetadataRef md) { diff --git a/src/LLVM/Internal/FFI/InstructionDefs.hsc b/src/LLVM/Internal/FFI/InstructionDefs.hsc --- a/src/LLVM/Internal/FFI/InstructionDefs.hsc +++ b/src/LLVM/Internal/FFI/InstructionDefs.hsc @@ -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; } \ diff --git a/src/LLVM/Internal/FFI/LLVMCTypes.hsc b/src/LLVM/Internal/FFI/LLVMCTypes.hsc --- a/src/LLVM/Internal/FFI/LLVMCTypes.hsc +++ b/src/LLVM/Internal/FFI/LLVMCTypes.hsc @@ -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) diff --git a/src/LLVM/Internal/FFI/Metadata.hpp b/src/LLVM/Internal/FFI/Metadata.hpp deleted file mode 100644 --- a/src/LLVM/Internal/FFI/Metadata.hpp +++ /dev/null @@ -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(Vals); -} -} diff --git a/src/LLVM/Internal/FFI/MetadataC.cpp b/src/LLVM/Internal/FFI/MetadataC.cpp --- a/src/LLVM/Internal/FFI/MetadataC.cpp +++ b/src/LLVM/Internal/FFI/MetadataC.cpp @@ -1,7 +1,6 @@ #define __STDC_LIMIT_MACROS #include -#include "LLVM/Internal/FFI/Metadata.hpp" #include "llvm/Support/FormattedStream.h" #include "llvm/Config/llvm-config.h" diff --git a/src/LLVM/Internal/FFI/OrcJIT.hs b/src/LLVM/Internal/FFI/OrcJIT.hs --- a/src/LLVM/Internal/FFI/OrcJIT.hs +++ b/src/LLVM/Internal/FFI/OrcJIT.hs @@ -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 diff --git a/src/LLVM/Internal/FFI/OrcJIT/CompileLayer.hs b/src/LLVM/Internal/FFI/OrcJIT/CompileLayer.hs --- a/src/LLVM/Internal/FFI/OrcJIT/CompileLayer.hs +++ b/src/LLVM/Internal/FFI/OrcJIT/CompileLayer.hs @@ -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) diff --git a/src/LLVM/Internal/FFI/OrcJITC.cpp b/src/LLVM/Internal/FFI/OrcJITC.cpp --- a/src/LLVM/Internal/FFI/OrcJITC.cpp +++ b/src/LLVM/Internal/FFI/OrcJITC.cpp @@ -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 @@ -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, std::function> LLVMLambdaResolver; -typedef LLVMLambdaResolver *LLVMLambdaResolverRef; +typedef std::shared_ptr *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> objects, - SectionMemoryManager *memMgr, JITSymbolResolver *resolver) = 0; - virtual ObjSetHandleT addObjectSet( - std::vector>> - objects, - SectionMemoryManager *memMgr, JITSymbolResolver *resolver) = 0; - virtual ObjSetHandleT addObjectSet( - std::vector>> - objects, - std::unique_ptr memMgr, - JITSymbolResolver *resolver) = 0; - virtual ObjSetHandleT addObjectSet( - std::vector>> - objects, - std::unique_ptr memMgr, - std::unique_ptr resolver) = 0; - virtual ObjSetHandleT addObjectSet( - std::vector>> - objects, - SectionMemoryManager *memMgr, - std::unique_ptr resolver) = 0; - virtual void removeObjectSet(ObjSetHandleT H) = 0; + typedef unsigned ObjHandleT; + virtual Expected + addObject(std::shared_ptr> object, + std::shared_ptr 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 class LinkingLayerT : public LinkingLayer { public: LinkingLayerT(T data_) : data(std::move(data_)) {} - ObjSetHandleT - addObjectSet(std::vector> 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>> - 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>> - objects, - std::unique_ptr 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>> - objects, - std::unique_ptr memMgr, - std::unique_ptr resolver) override { - auto handle = data.addObjectSet(std::move(objects), std::move(memMgr), - std::move(resolver)); - return handles.insert(handle); - } - ObjSetHandleT addObjectSet( - std::vector>> - objects, - SectionMemoryManager *memMgr, - std::unique_ptr resolver) override { - auto handle = data.addObjectSet(std::move(objects), std::move(memMgr), - std::move(resolver)); - return handles.insert(handle); + Expected + addObject(std::shared_ptr> object, + std::shared_ptr 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 handles; + HandleSet 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> Modules, - std::unique_ptr MemMgr, - std::unique_ptr Resolver) = 0; - virtual ModuleSetHandleT - addModuleSet(std::vector> Modules, - SectionMemoryManager *MemMgr, - std::unique_ptr Resolver) = 0; - virtual void removeModuleSet(ModuleSetHandleT H) = 0; + virtual Expected + addModule(std::shared_ptr Modules, + std::shared_ptr Resolver) = 0; + virtual Error removeModule(ModuleHandleT H) = 0; }; template class CompileLayerT : public CompileLayer { public: - CompileLayerT(T data_) : data(std::move(data_)) {} + template + CompileLayerT(Arg &&... arg) : data{std::forward(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> Modules, - std::unique_ptr MemMgr, - std::unique_ptr Resolver) override { - auto handle = data.addModuleSet(std::move(Modules), std::move(MemMgr), - std::move(Resolver)); - return handles.insert(handle); - } - ModuleSetHandleT - addModuleSet(std::vector> Modules, - SectionMemoryManager *MemMgr, - std::unique_ptr Resolver) override { - auto handle = data.addModuleSet(std::move(Modules), std::move(MemMgr), - std::move(Resolver)); - return handles.insert(handle); + Expected + addModule(std::shared_ptr Module, + std::shared_ptr 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 handles; + HandleSet handles; }; typedef llvm::orc::CompileOnDemandLayer LLVMCompileOnDemandLayer; @@ -204,7 +150,7 @@ typedef llvm::orc::IRTransformLayer< CompileLayer, - std::function(std::unique_ptr)>> + std::function(std::shared_ptr)>> LLVMIRTransformLayer; typedef llvm::orc::JITCompileCallbackManager *LLVMJITCompileCallbackManagerRef; @@ -225,19 +171,6 @@ return mangledName; } -static std::vector> -getModules(LLVMModuleRef *modules, unsigned moduleCount, - LLVMTargetDataRef dataLayout) { - std::vector> moduleVec(moduleCount); - for (unsigned i = 0; i < moduleCount; ++i) { - moduleVec.at(i) = std::unique_ptr(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, SimpleCompiler(*tmm))); + return new CompileLayerT>( + IRCompileLayer(*linkingLayer, + SimpleCompiler(*tmm))); } CompileLayer *LLVM_Hs_createCompileOnDemandLayer( @@ -255,24 +189,24 @@ LLVMJITCompileCallbackManagerRef callbackManager, LLVMIndirectStubsManagerBuilderRef stubsManager, LLVMBool cloneStubsIntoPartitions) { - return new CompileLayerT(LLVMCompileOnDemandLayer( + return new CompileLayerT( *compileLayer, [partitioningFtor](llvm::Function &f) -> std::set { std::set result; partitioningFtor(&f, &result); return result; }, - *callbackManager, *stubsManager, cloneStubsIntoPartitions)); + *callbackManager, *stubsManager, + static_cast(cloneStubsIntoPartitions)); } CompileLayer *LLVM_Hs_createIRTransformLayer(CompileLayer *compileLayer, Module *(*transform)(Module *)) { - std::function(std::unique_ptr)> transform_ = - [transform](std::unique_ptr module) { - return std::unique_ptr(transform(module.release())); + std::function(std::shared_ptr)> transform_ = + [transform](std::shared_ptr module) { + return std::shared_ptr(transform(module.get())); }; - return new CompileLayerT( - LLVMIRTransformLayer(*compileLayer, transform_)); + return new CompileLayerT(*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 uniqueResolver( - new LLVMLambdaResolver(*resolver)); - return compileLayer->addModuleSet(std::move(moduleVec), - make_unique(), - std::move(uniqueResolver)); +LLVMModuleHandle LLVM_Hs_CompileLayer_addModule(CompileLayer *compileLayer, + LLVMTargetDataRef dataLayout, + LLVMModuleRef module, + LLVMLambdaResolverRef resolver, + char **errorMessage) { + std::shared_ptr 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<>()); + return new LinkingLayerT(RTDyldObjectLinkingLayer( + []() { return std::make_shared(); })); } /* 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( + 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) { diff --git a/src/LLVM/Internal/FFI/PassManager.hs b/src/LLVM/Internal/FFI/PassManager.hs --- a/src/LLVM/Internal/FFI/PassManager.hs +++ b/src/LLVM/Internal/FFI/PassManager.hs @@ -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 diff --git a/src/LLVM/Internal/FFI/PassManagerC.cpp b/src/LLVM/Internal/FFI/PassManagerC.cpp --- a/src/LLVM/Internal/FFI/PassManagerC.cpp +++ b/src/LLVM/Internal/FFI/PassManagerC.cpp @@ -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( diff --git a/src/LLVM/Internal/FFI/Target.h b/src/LLVM/Internal/FFI/Target.h --- a/src/LLVM/Internal/FFI/Target.h +++ b/src/LLVM/Internal/FFI/Target.h @@ -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) \ diff --git a/src/LLVM/Internal/FFI/Target.hs b/src/LLVM/Internal/FFI/Target.hs --- a/src/LLVM/Internal/FFI/Target.hs +++ b/src/LLVM/Internal/FFI/Target.hs @@ -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 () diff --git a/src/LLVM/Internal/FFI/TargetC.cpp b/src/LLVM/Internal/FFI/TargetC.cpp --- a/src/LLVM/Internal/FFI/TargetC.cpp +++ b/src/LLVM/Internal/FFI/TargetC.cpp @@ -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; diff --git a/src/LLVM/Internal/FFI/Type.hs b/src/LLVM/Internal/FFI/Type.hs --- a/src/LLVM/Internal/FFI/Type.hs +++ b/src/LLVM/Internal/FFI/Type.hs @@ -150,3 +150,7 @@ -- | foreign import ccall unsafe "LLVM_Hs_TokenTypeInContext" tokenTypeInContext :: Ptr Context -> IO (Ptr Type) + +-- | +foreign import ccall unsafe "LLVMLabelTypeInContext" labelTypeInContext :: + Ptr Context -> IO (Ptr Type) diff --git a/src/LLVM/Internal/Function.hs b/src/LLVM/Internal/Function.hs --- a/src/LLVM/Internal/Function.hs +++ b/src/LLVM/Internal/Function.hs @@ -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) diff --git a/src/LLVM/Internal/Instruction.hs b/src/LLVM/Internal/Instruction.hs --- a/src/LLVM/Internal/Instruction.hs +++ b/src/LLVM/Internal/Instruction.hs @@ -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 diff --git a/src/LLVM/Internal/LibraryFunction.hsc b/src/LLVM/Internal/LibraryFunction.hsc --- a/src/LLVM/Internal/LibraryFunction.hsc +++ b/src/LLVM/Internal/LibraryFunction.hsc @@ -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"); \ } } diff --git a/src/LLVM/Internal/Module.hs b/src/LLVM/Internal/Module.hs --- a/src/LLVM/Internal/Module.hs +++ b/src/LLVM/Internal/Module.hs @@ -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 diff --git a/src/LLVM/Internal/OrcJIT.hs b/src/LLVM/Internal/OrcJIT.hs --- a/src/LLVM/Internal/OrcJIT.hs +++ b/src/LLVM/Internal/OrcJIT.hs @@ -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) diff --git a/src/LLVM/Internal/OrcJIT/CompileLayer.hs b/src/LLVM/Internal/OrcJIT/CompileLayer.hs --- a/src/LLVM/Internal/OrcJIT/CompileLayer.hs +++ b/src/LLVM/Internal/OrcJIT/CompileLayer.hs @@ -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. diff --git a/src/LLVM/Internal/PassManager.hs b/src/LLVM/Internal/PassManager.hs --- a/src/LLVM/Internal/PassManager.hs +++ b/src/LLVM/Internal/PassManager.hs @@ -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 ] ++ [ diff --git a/src/LLVM/Internal/Target.hs b/src/LLVM/Internal/Target.hs --- a/src/LLVM/Internal/Target.hs +++ b/src/LLVM/Internal/Target.hs @@ -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) + ] + -- | 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 diff --git a/src/LLVM/Internal/Type.hs b/src/LLVM/Internal/Type.hs --- a/src/LLVM/Internal/Type.hs +++ b/src/LLVM/Internal/Type.hs @@ -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 diff --git a/src/LLVM/Internal/Value.hs b/src/LLVM/Internal/Value.hs --- a/src/LLVM/Internal/Value.hs +++ b/src/LLVM/Internal/Value.hs @@ -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 diff --git a/src/LLVM/OrcJIT.hs b/src/LLVM/OrcJIT.hs --- a/src/LLVM/OrcJIT.hs +++ b/src/LLVM/OrcJIT.hs @@ -2,10 +2,10 @@ -- * CompileLayer CompileLayer, -- ** Add/remove modules - ModuleSetHandle, - addModuleSet, - removeModuleSet, - withModuleSet, + ModuleHandle, + addModule, + removeModule, + withModule, -- ** Search for symbols findSymbol, findSymbolIn, diff --git a/src/LLVM/Target/Options.hs b/src/LLVM/Target/Options.hs --- a/src/LLVM/Target/Options.hs +++ b/src/LLVM/Target/Options.hs @@ -17,11 +17,17 @@ | FloatingPointOperationFusionStrict deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic) +-- | +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' -- 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, diff --git a/src/LLVM/Transforms.hs b/src/LLVM/Transforms.hs --- a/src/LLVM/Transforms.hs +++ b/src/LLVM/Transforms.hs @@ -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 . diff --git a/test/LLVM/Test/CallingConvention.hs b/test/LLVM/Test/CallingConvention.hs --- a/test/LLVM/Test/CallingConvention.hs +++ b/test/LLVM/Test/CallingConvention.hs @@ -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) ] ] diff --git a/test/LLVM/Test/FunctionAttribute.hs b/test/LLVM/Test/FunctionAttribute.hs --- a/test/LLVM/Test/FunctionAttribute.hs +++ b/test/LLVM/Test/FunctionAttribute.hs @@ -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') ] diff --git a/test/LLVM/Test/Instructions.hs b/test/LLVM/Test/Instructions.hs --- a/test/LLVM/Test/Instructions.hs +++ b/test/LLVM/Test/Instructions.hs @@ -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"), diff --git a/test/LLVM/Test/Instrumentation.hs b/test/LLVM/Test/Instrumentation.hs --- a/test/LLVM/Test/Instrumentation.hs +++ b/test/LLVM/Test/Instrumentation.hs @@ -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), []) ], diff --git a/test/LLVM/Test/Module.hs b/test/LLVM/Test/Module.hs --- a/test/LLVM/Test/Module.hs +++ b/test/LLVM/Test/Module.hs @@ -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 diff --git a/test/LLVM/Test/Optimization.hs b/test/LLVM/Test/Optimization.hs --- a/test/LLVM/Test/Optimization.hs +++ b/test/LLVM/Test/Optimization.hs @@ -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 "" "" 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 "" "" 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")) ] [], diff --git a/test/LLVM/Test/OrcJIT.hs b/test/LLVM/Test/OrcJIT.hs --- a/test/LLVM/Test/OrcJIT.hs +++ b/test/LLVM/Test/OrcJIT.hs @@ -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)) diff --git a/test/LLVM/Test/Regression.hs b/test/LLVM/Test/Regression.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/Regression.hs @@ -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}") + ] diff --git a/test/LLVM/Test/Target.hs b/test/LLVM/Test/Target.hs --- a/test/LLVM/Test/Target.hs +++ b/test/LLVM/Test/Target.hs @@ -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" [ diff --git a/test/LLVM/Test/Tests.hs b/test/LLVM/Test/Tests.hs --- a/test/LLVM/Test/Tests.hs +++ b/test/LLVM/Test/Tests.hs @@ -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 ] diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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