diff --git a/.travis.yml b/.travis.yml index 6d5922c4..b508616e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -46,7 +46,7 @@ install: - export PATH=$HOME/cmake-3.19.7-Linux-x86_64/bin:$PATH - curl -L https://github.com/ninja-build/ninja/releases/download/v1.9.0/ninja-linux.zip -o ninja-linux.zip - unzip ninja-linux.zip -d $HOME/bin - - git clone https://github.com/llvm/llvm-project -b release/12.x --single-branch --depth 1 + - git clone https://github.com/llvm/llvm-project --single-branch --depth 1 - cd llvm-project/llvm - mkdir -p build && cd build - cmake -Wno-dev -G "Ninja" .. -DCMAKE_{BUILD_TYPE=Release,CXX_FLAGS_RELEASE=-O0,INSTALL_PREFIX=$HOME/llvm-build-${LLVM_VER}} -DLLVM_{TARGETS_TO_BUILD="X86",ENABLE_PROJECTS="clang;",INCLUDE_{TOOLS=ON,EXAMPLES=OFF,TESTS=OFF,BENCHMARKS=OFF},ENABLE_BINDINGS=OFF,PARALLEL_LINK_JOBS=1,BUILD_LLVM_DYLIB=ON,LINK_LLVM_DYLIB=ON} diff --git a/README.md b/README.md index a202f5bb..1499b879 100644 --- a/README.md +++ b/README.md @@ -62,8 +62,48 @@ and merely exposing them to Haskell as wrapped C or C++ functions. ## Contributing -We love all kinds of contributions so please feel free to open issues for -missing LLVM features, report & fix bugs or report API inconveniences. +We love all kinds of contributions so feel free to open issues for +missing LLVM features, report & fix bugs or report API +inconveniences. + +## Installing LLVM + +This branch tracks LLVM HEAD, meaning that the only way to build it is to +use a fresh checkout of LLVM sources. + +### Building from source + +Example of building LLVM from source. Detailed build instructions are available +on the LLVM.org website [here](http://llvm.org/docs/CMake.html). [CMake +3.4.3](http://www.cmake.org/cmake/resources/software.html) and a recent C++ +compiler are required, at least Clang 3.1, GCC 4.8, or Visual Studio 2015 +(Update 3). + + 1. Download and unpack the [LLVM source code](https://github.com/llvm/llvm-project): + ```sh + git clone https://github.com/llvm/llvm-project -b release/12.x --single-branch + cd llvm-project + ``` + + 2. Create a temporary build directory and `cd` to it, for example: + ```sh + mkdir build && cd build + ``` + + 3. Execute the following to configure the build. Here, `INSTALL_PREFIX` is + where LLVM is to be installed, for example `/usr/local`: + ```sh + cmake -DCMAKE_BUILD_TYPE=Release -DCMAKE_INSTALL_PREFIX=$INSTALL_PREFIX -DLLVM_PARALLEL_LINK_JOBS=1 -DLLVM_BUILD_LLVM_DYLIB=True -DLLVM_LINK_LLVM_DYLIB=True ../llvm + ``` + See [options and variables](http://llvm.org/docs/CMake.html#options-and-variables) + for a list of additional build parameters you can specify (we especially recommend the + `ninja` build system). + + 4. Build and install: + ```sh + cmake --build . + cmake --build . --target install + ``` ## Versioning diff --git a/llvm-hs-pure/CHANGELOG.md b/llvm-hs-pure/CHANGELOG.md index 5342670e..07f37a6f 100644 --- a/llvm-hs-pure/CHANGELOG.md +++ b/llvm-hs-pure/CHANGELOG.md @@ -1,4 +1,3 @@ - ## 12.0.0 (2021-03-19) * Update to LLVM 12.0 diff --git a/llvm-hs-pure/llvm-hs-pure.cabal b/llvm-hs-pure/llvm-hs-pure.cabal index 3ed4dcd4..0aeb1b65 100644 --- a/llvm-hs-pure/llvm-hs-pure.cabal +++ b/llvm-hs-pure/llvm-hs-pure.cabal @@ -1,6 +1,7 @@ +cabal-version: 2.2 name: llvm-hs-pure -version: 12.0.0 -license: BSD3 +version: 16.0.0 +license: BSD-3-Clause license-file: LICENSE author: Anthony Cowley, Stephen Diehl, Moritz Kiefer , Benjamin S. Scarlet maintainer: Anthony Cowley, Stephen Diehl, Moritz Kiefer @@ -9,7 +10,6 @@ homepage: http://github.com/llvm-hs/llvm-hs/ bug-reports: http://github.com/llvm-hs/llvm-hs/issues build-type: Simple stability: experimental -cabal-version: 1.24 category: Compilers/Interpreters, Code Generation synopsis: Pure Haskell LLVM functionality (no FFI). description: @@ -22,7 +22,7 @@ extra-source-files: CHANGELOG.md source-repository head type: git location: git://github.com/llvm-hs/llvm-hs.git - branch: llvm-12 + branch: llvm-head-unstable library default-language: Haskell2010 diff --git a/llvm-hs-pure/src/LLVM/AST/Constant.hs b/llvm-hs-pure/src/LLVM/AST/Constant.hs index dfab7934..b042cb3b 100644 --- a/llvm-hs-pure/src/LLVM/AST/Constant.hs +++ b/llvm-hs-pure/src/LLVM/AST/Constant.hs @@ -32,7 +32,7 @@ data Constant | Vector { memberValues :: [ Constant ] } | Undef { constantType :: Type } | BlockAddress { blockAddressFunction :: Name, blockAddressBlock :: Name } - | GlobalReference Type Name + | GlobalReference Name | TokenNone | Add { nsw :: Bool, @@ -64,16 +64,6 @@ data Constant operand0 :: Constant, operand1 :: Constant } - | UDiv { - exact :: Bool, - operand0 :: Constant, - operand1 :: Constant - } - | SDiv { - exact :: Bool, - operand0 :: Constant, - operand1 :: Constant - } | FDiv { operand0 :: Constant, operand1 :: Constant @@ -120,6 +110,7 @@ data Constant } | GetElementPtr { inBounds :: Bool, + type' :: Type, address :: Constant, indices :: [Constant] } @@ -204,15 +195,6 @@ data Constant operand1 :: Constant, mask :: Constant } - | ExtractValue { - aggregate :: Constant, - indices' :: [Word32] - } - | InsertValue { - aggregate :: Constant, - element :: Constant, - indices' :: [Word32] - } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) @@ -242,6 +224,6 @@ unsignedIntegerValue _ = error "unsignedIntegerValue is only defined for Int" sizeof :: Word32 -> Type -> Constant sizeof szBits t = PtrToInt szPtr (IntegerType szBits) where - ptrType = PointerType t (AddrSpace 0) + ptrType = PointerType (AddrSpace 0) nullPtr = IntToPtr (Int szBits 0) ptrType - szPtr = GetElementPtr True nullPtr [Int szBits 1] + szPtr = GetElementPtr True t nullPtr [Int szBits 1] diff --git a/llvm-hs-pure/src/LLVM/AST/FunctionAttribute.hs b/llvm-hs-pure/src/LLVM/AST/FunctionAttribute.hs index 38974c46..a790d1bc 100644 --- a/llvm-hs-pure/src/LLVM/AST/FunctionAttribute.hs +++ b/llvm-hs-pure/src/LLVM/AST/FunctionAttribute.hs @@ -11,6 +11,7 @@ data FunctionAttribute | Builtin | Cold | Convergent + | Hot | InaccessibleMemOnly | InaccessibleMemOrArgMemOnly | InlineHint @@ -19,16 +20,22 @@ data FunctionAttribute | MustProgress | Naked | NoBuiltin + | NoCallback + | NoCfCheck | NoDuplicate | NoFree | NoImplicitFloat | NoInline - | NonLazyBind + | NoMerge + | NoProfile | NoRecurse | NoRedZone | NoReturn | NoSync | NoUnwind + | NonLazyBind + | NullPointerIsValid + | OptForFuzzing | OptimizeForSize | OptimizeNone | ReadNone @@ -37,9 +44,12 @@ data FunctionAttribute | SafeStack | SanitizeAddress | SanitizeHWAddress + | SanitizeMemTag | SanitizeMemory | SanitizeThread + | ShadowCallStack | Speculatable + | SpeculativeLoadHardening | StackAlignment Word64 | StackProtect | StackProtectReq @@ -50,6 +60,11 @@ data FunctionAttribute stringAttributeValue :: ShortByteString -- ^ Use "" for no value -- the two are conflated } | UWTable + | VScaleRange { + vScaleRangeMin :: Word32, + vScaleRangeMax :: Word32 -- ^ Optional max is not supported. Set it to the minimum + -- value if unspecified. + } | WillReturn | WriteOnly deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) diff --git a/llvm-hs-pure/src/LLVM/AST/Instruction.hs b/llvm-hs-pure/src/LLVM/AST/Instruction.hs index 1b48d857..2ab85d2c 100644 --- a/llvm-hs-pure/src/LLVM/AST/Instruction.hs +++ b/llvm-hs-pure/src/LLVM/AST/Instruction.hs @@ -51,6 +51,7 @@ data Terminator | Invoke { callingConvention' :: CallingConvention, returnAttributes' :: [PA.ParameterAttribute], + type'' :: Type, function' :: CallableOperand, arguments' :: [(Operand, [PA.ParameterAttribute])], functionAttributes' :: [Either FA.GroupID FA.FunctionAttribute], @@ -266,6 +267,7 @@ data Instruction } | Load { volatile :: Bool, + type' :: Type, address :: Operand, maybeAtomicity :: Maybe Atomicity, alignment :: Word32, @@ -281,6 +283,7 @@ data Instruction } | GetElementPtr { inBounds :: Bool, + type' :: Type, address :: Operand, indices :: [Operand], metadata :: InstructionMetadata @@ -294,6 +297,7 @@ data Instruction address :: Operand, expected :: Operand, replacement :: Operand, + alignment :: Word32, atomicity :: Atomicity, failureMemoryOrdering :: MemoryOrdering, metadata :: InstructionMetadata @@ -303,6 +307,7 @@ data Instruction rmwOperation :: RMWOperation, address :: Operand, value :: Operand, + alignment :: Word32, atomicity :: Atomicity, metadata :: InstructionMetadata } @@ -403,6 +408,7 @@ data Instruction tailCallKind :: Maybe TailCallKind, callingConvention :: CallingConvention, returnAttributes :: [PA.ParameterAttribute], + type' :: Type, function :: CallableOperand, arguments :: [(Operand, [PA.ParameterAttribute])], functionAttributes :: [Either FA.GroupID FA.FunctionAttribute], diff --git a/llvm-hs-pure/src/LLVM/AST/ParameterAttribute.hs b/llvm-hs-pure/src/LLVM/AST/ParameterAttribute.hs index a05873ce..f9bd5a27 100644 --- a/llvm-hs-pure/src/LLVM/AST/ParameterAttribute.hs +++ b/llvm-hs-pure/src/LLVM/AST/ParameterAttribute.hs @@ -2,26 +2,28 @@ module LLVM.AST.ParameterAttribute where import LLVM.Prelude +import LLVM.AST.Type -- | data ParameterAttribute = Alignment Word64 - | ByVal + | ByVal Type | Dereferenceable Word64 | DereferenceableOrNull Word64 | ImmArg - | InAlloca + | InAlloca Type | InReg | Nest | NoAlias | NoCapture | NoFree + | NoUndef | NonNull | ReadNone | ReadOnly | Returned | SignExt - | SRet + | SRet Type | SwiftError | SwiftSelf | WriteOnly diff --git a/llvm-hs-pure/src/LLVM/AST/Type.hs b/llvm-hs-pure/src/LLVM/AST/Type.hs index 686ce587..a0c548d6 100644 --- a/llvm-hs-pure/src/LLVM/AST/Type.hs +++ b/llvm-hs-pure/src/LLVM/AST/Type.hs @@ -23,7 +23,7 @@ data Type -- | | IntegerType { typeBits :: Word32 } -- | - | PointerType { pointerReferent :: Type, pointerAddrSpace :: AddrSpace } + | PointerType { pointerAddrSpace :: AddrSpace } -- | | FloatingPointType { floatingPointType :: FloatingPointType } -- | @@ -72,9 +72,9 @@ i64 = IntegerType 64 i128 :: Type i128 = IntegerType 128 --- | An abbreviation for 'PointerType' t ('AddrSpace' 0) -ptr :: Type -> Type -ptr t = PointerType t (AddrSpace 0) +-- | An abbreviation for 'PointerType' ('AddrSpace' 0) +ptr :: Type +ptr = PointerType (AddrSpace 0) -- | An abbreviation for 'FloatingPointType' 'HalfFP' half :: Type diff --git a/llvm-hs-pure/src/LLVM/AST/Typed.hs b/llvm-hs-pure/src/LLVM/AST/Typed.hs index fcbf72a4..cc8f7df5 100644 --- a/llvm-hs-pure/src/LLVM/AST/Typed.hs +++ b/llvm-hs-pure/src/LLVM/AST/Typed.hs @@ -3,7 +3,6 @@ -- | Querying the type of LLVM expressions module LLVM.AST.Typed ( Typed(..), - getElementType, indexTypeByConstants, indexTypeByOperands, extractValueType, @@ -61,8 +60,8 @@ instance Typed C.Constant where (Right t') -> return $ Right $ VectorType (fromIntegral $ length memberValues) t' typeOf (C.Undef t) = return $ Right t - typeOf (C.BlockAddress {}) = return $ Right $ ptr i8 - typeOf (C.GlobalReference t _) = return $ Right t + typeOf (C.BlockAddress {}) = return $ Right ptr + typeOf (C.GlobalReference _) = return $ Right ptr typeOf (C.Add {..}) = typeOf operand0 typeOf (C.FAdd {..}) = typeOf operand0 typeOf (C.FDiv {..}) = typeOf operand0 @@ -71,8 +70,6 @@ instance Typed C.Constant where typeOf (C.FSub {..}) = typeOf operand0 typeOf (C.Mul {..}) = typeOf operand0 typeOf (C.FMul {..}) = typeOf operand0 - typeOf (C.UDiv {..}) = typeOf operand0 - typeOf (C.SDiv {..}) = typeOf operand0 typeOf (C.URem {..}) = typeOf operand0 typeOf (C.SRem {..}) = typeOf operand0 typeOf (C.Shl {..}) = typeOf operand0 @@ -81,11 +78,7 @@ instance Typed C.Constant where typeOf (C.And {..}) = typeOf operand0 typeOf (C.Or {..}) = typeOf operand0 typeOf (C.Xor {..}) = typeOf operand0 - typeOf (C.GetElementPtr {..}) = do - aty <- typeOf address - case aty of - (Left _) -> return aty - (Right aty') -> indexTypeByConstants aty' indices + typeOf (C.GetElementPtr {}) = return $ Right ptr typeOf (C.Trunc {..}) = return $ Right type' typeOf (C.ZExt {..}) = return $ Right type' typeOf (C.SExt {..}) = return $ Right type' @@ -124,19 +117,12 @@ instance Typed C.Constant where case (t0, tm) of (Right (VectorType _ t), Right (VectorType m _)) -> return $ Right $ VectorType m t _ -> return $ Left "The first operand of an shufflevector instruction is a value of vector type. (Malformed AST)" - typeOf (C.ExtractValue {..}) = do - t <- typeOf aggregate - case t of - (Left _) -> return t - (Right t') -> extractValueType indices' t' - typeOf (C.InsertValue {..}) = typeOf aggregate typeOf (C.TokenNone) = return $ Right TokenType typeOf (C.AddrSpaceCast {..}) = return $ Right type' --- | Index into a type using a list of 'Constant' values. Returns a pointer type whose referent is the indexed type, or an error message if indexing was not possible. +-- | Index into a type using a list of 'Constant' values. Returns the indexed type, or an error message if indexing was not possible. indexTypeByConstants :: (HasCallStack, MonadModuleBuilder m) => Type -> [C.Constant] -> m (Either String Type) -indexTypeByConstants ty [] = return $ Right $ ptr ty -indexTypeByConstants (PointerType ty _) (_:is) = indexTypeByConstants ty is +indexTypeByConstants ty [] = return $ Right ty indexTypeByConstants (StructureType _ elTys) (C.Int 32 val:is) = indexTypeByConstants (elTys !! fromIntegral val) is indexTypeByConstants (StructureType _ _) (i:_) = @@ -150,10 +136,9 @@ indexTypeByConstants (NamedTypeReference n) is = do Just ty -> indexTypeByConstants ty is indexTypeByConstants ty _ = return $ Left $ "Expecting aggregate type. (Malformed AST): " ++ show ty --- | Index into a type using a list of 'Operand' values. Returns a pointer type whose referent is the indexed type, or an error message if indexing was not possible. +-- | Index into a type using a list of 'Operand' values. Returns the indexed type, or an error message if indexing was not possible. indexTypeByOperands :: (HasCallStack, MonadModuleBuilder m) => Type -> [Operand] -> m (Either String Type) -indexTypeByOperands ty [] = return $ Right $ ptr ty -indexTypeByOperands (PointerType ty _) (_:is) = indexTypeByOperands ty is +indexTypeByOperands ty [] = return $ Right ty indexTypeByOperands (StructureType _ elTys) (ConstantOperand (C.Int 32 val):is) = indexTypeByOperands (elTys !! fromIntegral val) is indexTypeByOperands (StructureType _ _) (i:_) = @@ -167,10 +152,6 @@ indexTypeByOperands (NamedTypeReference n) is = do Just ty -> indexTypeByOperands ty is indexTypeByOperands ty _ = return $ Left $ "Expecting aggregate type. (Malformed AST): " ++ show ty -getElementType :: Type -> Either String Type -getElementType (PointerType t _) = Right t -getElementType t = Left $ "Expecting pointer type. (Malformed AST): " ++ show t - extractValueType :: (HasCallStack, MonadModuleBuilder m) => [Word32] -> Type -> m (Either String Type) extractValueType [] ty = return $ Right ty extractValueType (i : is) (ArrayType numEls elTy) diff --git a/llvm-hs-pure/src/LLVM/IRBuilder/Instruction.hs b/llvm-hs-pure/src/LLVM/IRBuilder/Instruction.hs index cc0f35f9..7058c513 100644 --- a/llvm-hs-pure/src/LLVM/IRBuilder/Instruction.hs +++ b/llvm-hs-pure/src/LLVM/IRBuilder/Instruction.hs @@ -179,19 +179,11 @@ xor a b = do -- | See . alloca :: MonadIRBuilder m => Type -> Maybe Operand -> Word32 -> m Operand -alloca ty count align = emitInstr (ptr ty) $ Alloca ty count align [] +alloca ty count align = emitInstr ptr $ Alloca ty count align [] -- | See . -load :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Word32 -> m Operand -load a align = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> do - let retty = case ta' of - PointerType ty _ -> ty - _ -> error "Cannot load non-pointer (Malformed AST)." - emitInstr retty $ Load False a Nothing align [] +load :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Type -> Operand -> Word32 -> m Operand +load ty a align = emitInstr ty $ Load False ty a Nothing align [] -- | See . store :: MonadIRBuilder m => Operand -> Word32 -> Operand -> m () @@ -199,16 +191,8 @@ store addr align val = emitInstrVoid $ Store False addr val Nothing align [] -- | Emit the @getelementptr@ instruction. -- See . -gep :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> [Operand] -> m Operand -gep addr is = do - ta <- typeOf addr - case ta of - (Left s) -> error s - (Right ta') -> do - ty <- indexTypeByOperands ta' is - case ty of - (Left s) -> error s - (Right ty') -> emitInstr ty' (GetElementPtr False addr is []) +gep :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Type -> Operand -> [Operand] -> m Operand +gep ty addr is = emitInstr ptr $ GetElementPtr False ty addr is [] -- | Emit the @trunc ... to@ instruction. -- See . @@ -311,7 +295,7 @@ extractValue a i = do retType <- indexTypeByOperands aggType (map (ConstantOperand . C.Int 32 . fromIntegral) i) case retType of (Left s) -> error s - (Right retType') -> emitInstr (pointerReferent retType') $ ExtractValue a i [] + (Right retType') -> emitInstr retType' $ ExtractValue a i [] -- | See . insertValue :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> [Word32] -> m Operand @@ -350,27 +334,23 @@ retVoid :: MonadIRBuilder m => m () retVoid = emitTerm (Ret Nothing []) -- | See . -call :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> [(Operand, [ParameterAttribute])] -> m Operand -call fun args = do +call :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Type -> Operand -> [(Operand, [ParameterAttribute])] -> m Operand +call funty fun args = do let instr = Call { AST.tailCallKind = Nothing , AST.callingConvention = CC.C , AST.returnAttributes = [] + , AST.type' = funty , AST.function = Right fun , AST.arguments = args , AST.functionAttributes = [] , AST.metadata = [] } - tf <- typeOf fun - case tf of - (Left s) -> error s - (Right (FunctionType r _ _)) -> case r of - VoidType -> emitInstrVoid instr >> (pure (ConstantOperand (C.Undef void))) - _ -> emitInstr r instr - (Right (PointerType (FunctionType r _ _) _)) -> case r of + case funty of + FunctionType r _ _ -> case r of VoidType -> emitInstrVoid instr >> (pure (ConstantOperand (C.Undef void))) _ -> emitInstr r instr - (Right _) -> error "Cannot call non-function (Malformed AST)." + _ -> error "Cannot call non-function (Malformed AST)." -- | See . ret :: MonadIRBuilder m => Operand -> m () @@ -422,11 +402,9 @@ globalStringPtr str nm = do , unnamedAddr = Just GlobalAddr } return $ C.GetElementPtr True - (C.GlobalReference (ptr ty') nm) - [(C.Int 32 0), (C.Int 32 0)] + ty' + (C.GlobalReference nm) + [(C.Int 32 0), (C.Int 32 0)] sizeof :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Word32 -> Type -> m Operand -sizeof szBits ty = do - tyNullPtr <- inttoptr (ConstantOperand $ C.Int szBits 0) (ptr ty) - tySzPtr <- gep tyNullPtr [ConstantOperand $ C.Int szBits 1] - ptrtoint tySzPtr $ IntegerType szBits +sizeof szBits ty = return $ ConstantOperand $ C.sizeof szBits ty diff --git a/llvm-hs-pure/src/LLVM/IRBuilder/Module.hs b/llvm-hs-pure/src/LLVM/IRBuilder/Module.hs index b9bb9b91..fa5e2765 100644 --- a/llvm-hs-pure/src/LLVM/IRBuilder/Module.hs +++ b/llvm-hs-pure/src/LLVM/IRBuilder/Module.hs @@ -147,9 +147,8 @@ function label argtys retty body = do , returnType = retty , basicBlocks = blocks } - funty = ptr $ FunctionType retty (fst <$> argtys) False emitDefn def - pure $ ConstantOperand $ C.GlobalReference funty label + pure $ ConstantOperand $ C.GlobalReference label -- | An external function definition extern @@ -165,8 +164,7 @@ extern nm argtys retty = do , parameters = ([Parameter ty (mkName "") [] | ty <- argtys], False) , returnType = retty } - let funty = ptr $ FunctionType retty argtys False - pure $ ConstantOperand $ C.GlobalReference funty nm + pure $ ConstantOperand $ C.GlobalReference nm -- | An external variadic argument function definition externVarArgs @@ -182,8 +180,7 @@ externVarArgs nm argtys retty = do , parameters = ([Parameter ty (mkName "") [] | ty <- argtys], True) , returnType = retty } - let funty = ptr $ FunctionType retty argtys True - pure $ ConstantOperand $ C.GlobalReference funty nm + pure $ ConstantOperand $ C.GlobalReference nm -- | A global variable definition global @@ -199,7 +196,7 @@ global nm ty initVal = do , linkage = External , initializer = Just initVal } - pure $ ConstantOperand $ C.GlobalReference (ptr ty) nm + pure $ ConstantOperand $ C.GlobalReference nm -- | A named type definition typedef diff --git a/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs b/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs index 52cb7fe4..c6a6a8ad 100644 --- a/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs +++ b/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs @@ -149,20 +149,13 @@ tests = (UnName 7) [ UnName 8 := GetElementPtr { inBounds = False, - address = ConstantOperand (C.Null (AST.ptr (AST.ptr (AST.ptr AST.i32)))), + type' = AST.i32, + address = ConstantOperand (C.Null AST.ptr), indices = - [ ConstantOperand (C.Int 32 10) - , ConstantOperand (C.Int 32 20) - , ConstantOperand (C.Int 32 30) + [ ConstantOperand (C.Int 32 40) ], metadata = [] } - , UnName 9 := GetElementPtr { - inBounds = False, - address = LocalReference (AST.ptr AST.i32) (UnName 8), - indices = [ ConstantOperand (C.Int 32 40) ], - metadata = [] - } ] (Do (Ret Nothing [])) ] @@ -187,8 +180,8 @@ recursiveFunctionCalls = do { tailCallKind = Nothing , callingConvention = CC.C , returnAttributes = [] - , I.function = - Right (ConstantOperand (C.GlobalReference (AST.ptr (FunctionType AST.i32 [AST.i32] False)) (Name "f"))) + , type' = (FunctionType AST.i32 [AST.i32] False) + , I.function = Right (ConstantOperand (C.GlobalReference (Name "f"))) , arguments = [(LocalReference (IntegerType {typeBits = 32}) (Name "a_0"),[])] , functionAttributes = [] , metadata = [] @@ -203,7 +196,7 @@ recursiveFunctionCalls = do m = buildModule "exampleModule" $ mdo f <- function "f" [(AST.i32, "a")] AST.i32 $ \[a] -> mdo entry <- block `named` "entry"; do - c <- call f [(a, [])] + c <- call (FunctionType AST.i32 [AST.i32] False) f [(a, [])] ret c pure () @@ -213,7 +206,7 @@ callWorksWithConstantGlobals = do { moduleName = "exampleModule" , moduleDefinitions = [ GlobalDefinition functionDefaults { - LLVM.AST.Global.returnType = AST.ptr AST.i8, + LLVM.AST.Global.returnType = AST.ptr, LLVM.AST.Global.name = Name "malloc", LLVM.AST.Global.parameters = ([Parameter (IntegerType {typeBits = 64}) (Name "") []],False), LLVM.AST.Global.basicBlocks = [] @@ -224,11 +217,12 @@ callWorksWithConstantGlobals = do LLVM.AST.Global.parameters = ([],False), LLVM.AST.Global.basicBlocks = [ BasicBlock (UnName 0) [ - UnName 1 := Call { tailCallKind = Nothing + UnName 1 := Call + { tailCallKind = Nothing + , type' = FunctionType {resultType = AST.ptr, argumentTypes = [IntegerType {typeBits = 64}], isVarArg = False} , I.function = Right ( ConstantOperand ( C.GlobalReference - (AST.ptr $ FunctionType {resultType = AST.ptr $ IntegerType {typeBits = 8}, argumentTypes = [IntegerType {typeBits = 64}], isVarArg = False}) (Name "malloc") ) ) @@ -250,9 +244,9 @@ resolvesTypeDefs = do buildModule "" builder @?= ast where builder = mdo pairTy <- typedef "pair" (Just (StructureType False [AST.i32, AST.i32])) - function "f" [(AST.ptr pairTy, "ptr"), (AST.i32, "x"), (AST.i32, "y")] AST.void $ \[ptr, x, y] -> do - xPtr <- gep ptr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] - yPtr <- gep ptr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] + function "f" [(AST.ptr, "ptr"), (AST.i32, "x"), (AST.i32, "y")] AST.void $ \[ptr, x, y] -> do + xPtr <- gep pairTy ptr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] + yPtr <- gep pairTy ptr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] store xPtr 0 x store yPtr 0 y function "g" [(pairTy, "pair")] AST.i32 $ \[pair] -> do @@ -267,7 +261,7 @@ resolvesTypeDefs = do [ TypeDefinition "pair" (Just (StructureType False [AST.i32, AST.i32])) , GlobalDefinition functionDefaults { LLVM.AST.Global.name = "f" - , LLVM.AST.Global.parameters = ( [ Parameter (AST.ptr (NamedTypeReference "pair")) "ptr_0" [] + , LLVM.AST.Global.parameters = ( [ Parameter AST.ptr "ptr_0" [] , Parameter AST.i32 "x_0" [] , Parameter AST.i32 "y_0" []] , False) @@ -276,19 +270,21 @@ resolvesTypeDefs = do [ BasicBlock (UnName 0) [ UnName 1 := GetElementPtr { inBounds = False - , address = LocalReference (AST.ptr (NamedTypeReference "pair")) "ptr_0" + , type' = NamedTypeReference "pair" + , address = LocalReference AST.ptr "ptr_0" , indices = [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] , metadata = [] } , UnName 2 := GetElementPtr { inBounds = False - , address = LocalReference (AST.ptr (NamedTypeReference "pair")) "ptr_0" + , type' = NamedTypeReference "pair" + , address = LocalReference AST.ptr "ptr_0" , indices = [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] , metadata = [] } , Do $ Store { volatile = False - , address = LocalReference (AST.ptr AST.i32) (UnName 1) + , address = LocalReference AST.ptr (UnName 1) , value = LocalReference AST.i32 "x_0" , maybeAtomicity = Nothing , alignment = 0 @@ -296,7 +292,7 @@ resolvesTypeDefs = do } , Do $ Store { volatile = False - , address = LocalReference (AST.ptr AST.i32) (UnName 2) + , address = LocalReference AST.ptr (UnName 2) , value = LocalReference AST.i32 "y_0" , maybeAtomicity = Nothing , alignment = 0 @@ -343,13 +339,13 @@ resolvesConstantTypeDefs = do pairTy <- typedef "pair" (Just (StructureType False [AST.i32, AST.i32])) globalPair <- global "gpair" pairTy (C.AggregateZero pairTy) function "f" [(AST.i32, "x"), (AST.i32, "y")] AST.void $ \[x, y] -> do - let ptr = ConstantOperand $ C.GlobalReference (AST.ptr pairTy) "gpair" - xPtr <- gep ptr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] - yPtr <- gep ptr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] + let ptr = ConstantOperand $ C.GlobalReference "gpair" + xPtr <- gep pairTy ptr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] + yPtr <- gep pairTy ptr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] store xPtr 0 x store yPtr 0 y function "g" [] AST.i32 $ \[] -> do - pair <- load (ConstantOperand $ C.GlobalReference (AST.ptr pairTy) "gpair") 0 + pair <- load pairTy (ConstantOperand $ C.GlobalReference "gpair") 0 x <- extractValue pair [0] y <- extractValue pair [1] z <- add x y @@ -375,19 +371,21 @@ resolvesConstantTypeDefs = do [ BasicBlock (UnName 0) [ UnName 1 := GetElementPtr { inBounds = False - , address = ConstantOperand (C.GlobalReference (AST.ptr (NamedTypeReference "pair")) "gpair") + , type' = NamedTypeReference "pair" + , address = ConstantOperand (C.GlobalReference "gpair") , indices = [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] , metadata = [] } , UnName 2 := GetElementPtr { inBounds = False - , address = ConstantOperand (C.GlobalReference (AST.ptr (NamedTypeReference "pair")) "gpair") + , type' = NamedTypeReference "pair" + , address = ConstantOperand (C.GlobalReference "gpair") , indices = [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] , metadata = [] } , Do $ Store { volatile = False - , address = LocalReference (AST.ptr AST.i32) (UnName 1) + , address = LocalReference AST.ptr (UnName 1) , value = LocalReference AST.i32 "x_0" , maybeAtomicity = Nothing , alignment = 0 @@ -395,7 +393,7 @@ resolvesConstantTypeDefs = do } , Do $ Store { volatile = False - , address = LocalReference (AST.ptr AST.i32) (UnName 2) + , address = LocalReference AST.ptr (UnName 2) , value = LocalReference AST.i32 "y_0" , maybeAtomicity = Nothing , alignment = 0 @@ -413,7 +411,8 @@ resolvesConstantTypeDefs = do [ BasicBlock (UnName 0) [ UnName 1 := Load { volatile = False, - address = ConstantOperand (C.GlobalReference (AST.ptr (NamedTypeReference "pair")) "gpair"), + type' = NamedTypeReference "pair", + address = ConstantOperand (C.GlobalReference "gpair"), maybeAtomicity = Nothing, alignment = 0, metadata = [] @@ -605,9 +604,7 @@ example = mkModule $ execModuleBuilder emptyModuleBuilder $ mdo retVoid blk3 <- block; do - let nul = cons $ C.Null $ AST.ptr $ AST.ptr $ AST.ptr $ IntegerType 32 - addr <- gep nul [cons $ C.Int 32 10, cons $ C.Int 32 20, cons $ C.Int 32 30] - addr' <- gep addr [cons $ C.Int 32 40] + addr <- gep AST.i32 (cons (C.Null AST.ptr)) [cons $ C.Int 32 40] retVoid pure () @@ -617,13 +614,13 @@ example = mkModule $ execModuleBuilder emptyModuleBuilder $ mdo funcCall :: Module funcCall = mkModule $ execModuleBuilder emptyModuleBuilder $ mdo - extern "malloc" [AST.i64] (AST.ptr AST.i8) + extern "malloc" [AST.i64] AST.ptr - let mallocTy = AST.ptr $ AST.FunctionType (AST.ptr AST.i8) [AST.i64] False + let mallocTy = AST.FunctionType AST.ptr [AST.i64] False function "omg" [] (AST.void) $ \_ -> do let size = int64 10 - call (ConstantOperand $ C.GlobalReference mallocTy "malloc") [(size, [])] + call mallocTy (ConstantOperand $ C.GlobalReference "malloc") [(size, [])] unreachable where mkModule ds = defaultModule { moduleName = "exampleModule", moduleDefinitions = ds } diff --git a/llvm-hs/Setup.hs b/llvm-hs/Setup.hs index 729cdd75..52549cc5 100644 --- a/llvm-hs/Setup.hs +++ b/llvm-hs/Setup.hs @@ -41,7 +41,7 @@ lookupFlagAssignment = lookup #endif llvmVersion :: Version -llvmVersion = mkVersion [12,0] +llvmVersion = mkVersion [16,0] -- Ordered by decreasing specificty so we will prefer llvm-config-9.0 -- over llvm-config-9 over llvm-config. diff --git a/llvm-hs/default.nix b/llvm-hs/default.nix deleted file mode 100644 index 37018b37..00000000 --- a/llvm-hs/default.nix +++ /dev/null @@ -1,26 +0,0 @@ -{ mkDerivation, array, attoparsec, base, bytestring, Cabal -, containers, exceptions, llvm-config, llvm-hs-pure, mtl -, pretty-show, QuickCheck, stdenv, tasty, tasty-hunit -, tasty-quickcheck, template-haskell, temporary, transformers -, transformers-compat, utf8-string -}: -mkDerivation { - pname = "llvm-hs"; - version = "4.1.0.0"; - src = ./.; - configureFlags = [ "-fshared-llvm" ]; - setupHaskellDepends = [ base Cabal containers ]; - libraryHaskellDepends = [ - array attoparsec base bytestring containers exceptions llvm-hs-pure - mtl template-haskell transformers transformers-compat utf8-string - ]; - libraryToolDepends = [ llvm-config ]; - testHaskellDepends = [ - base bytestring containers llvm-hs-pure mtl pretty-show QuickCheck - tasty tasty-hunit tasty-quickcheck temporary transformers - transformers-compat - ]; - homepage = "http://github.com/llvm-hs/llvm-hs/"; - description = "General purpose LLVM bindings"; - license = stdenv.lib.licenses.bsd3; -} diff --git a/llvm-hs/llvm-hs.cabal b/llvm-hs/llvm-hs.cabal index 59dbaaee..1a5c297a 100644 --- a/llvm-hs/llvm-hs.cabal +++ b/llvm-hs/llvm-hs.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: llvm-hs -version: 12.0.0 +version: 16.0.0 license: BSD-3-Clause license-file: LICENSE author: Anthony Cowley, Stephen Diehl, Moritz Kiefer , Benjamin S. Scarlet @@ -47,7 +47,7 @@ extra-source-files: CHANGELOG.md source-repository head type: git location: git://github.com/llvm-hs/llvm-hs.git - branch: llvm-12 + branch: llvm-head-unstable flag shared-llvm description: link against llvm shared rather than static library @@ -80,13 +80,13 @@ library -fno-warn-orphans -optcxx=-O3 -optcxx=-Wall - -optcxx=-std=c++14 + -optcxx=-std=c++17 -optcxx=-lstdc++ cxx-options: -O3 -Wall - -std=c++14 + -std=c++17 if flag(llvm-with-rtti) cxx-options: -frtti @@ -114,7 +114,8 @@ library template-haskell >= 2.5.0.0, containers >= 0.4.2.1, array >= 0.4.0.0, - llvm-hs-pure == 12.0.* + llvm-hs-pure == 16.0.* + hs-source-dirs: src default-extensions: NoImplicitPrelude @@ -166,7 +167,7 @@ library LLVM.Internal.ObjectFile LLVM.Internal.OrcJIT LLVM.Internal.Operand - LLVM.Internal.PassManager + LLVM.Internal.Passes LLVM.Internal.RawOStream LLVM.Internal.RMWOperation LLVM.Internal.String @@ -176,8 +177,8 @@ library LLVM.Internal.Type LLVM.Internal.Value LLVM.Internal.FFI.Analysis - LLVM.Internal.FFI.Attribute LLVM.Internal.FFI.Assembly + LLVM.Internal.FFI.Attribute LLVM.Internal.FFI.BasicBlock LLVM.Internal.FFI.BinaryOperator LLVM.Internal.FFI.Bitcode @@ -189,6 +190,7 @@ library LLVM.Internal.FFI.Context LLVM.Internal.FFI.DataLayout LLVM.Internal.FFI.DynamicLibrary + LLVM.Internal.FFI.Error LLVM.Internal.FFI.ExecutionEngine LLVM.Internal.FFI.Function LLVM.Internal.FFI.GlobalAlias @@ -204,15 +206,14 @@ library LLVM.Internal.FFI.Module LLVM.Internal.FFI.ObjectFile LLVM.Internal.FFI.OrcJIT - LLVM.Internal.FFI.PassManager + LLVM.Internal.FFI.Passes LLVM.Internal.FFI.PtrHierarchy - LLVM.Internal.FFI.RawOStream LLVM.Internal.FFI.RTDyldMemoryManager - LLVM.Internal.FFI.ShortByteString + LLVM.Internal.FFI.RawOStream LLVM.Internal.FFI.SMDiagnostic + LLVM.Internal.FFI.ShortByteString LLVM.Internal.FFI.Target LLVM.Internal.FFI.Threading - LLVM.Internal.FFI.Transforms LLVM.Internal.FFI.Type LLVM.Internal.FFI.User LLVM.Internal.FFI.Value @@ -220,13 +221,12 @@ library LLVM.Linking LLVM.Module LLVM.OrcJIT - LLVM.PassManager + LLVM.Passes LLVM.Relocation LLVM.Target LLVM.Target.LibraryFunction LLVM.Target.Options LLVM.Threading - LLVM.Transforms other-modules: Control.Monad.AnyCont @@ -241,6 +241,7 @@ library src/LLVM/Internal/FFI/BuilderC.cpp src/LLVM/Internal/FFI/CallingConventionC.cpp src/LLVM/Internal/FFI/ConstantC.cpp + src/LLVM/Internal/FFI/ContextC.cpp src/LLVM/Internal/FFI/CommandLineC.cpp src/LLVM/Internal/FFI/ErrorHandling.cpp src/LLVM/Internal/FFI/ExecutionEngineC.cpp @@ -252,8 +253,8 @@ library src/LLVM/Internal/FFI/MetadataC.cpp src/LLVM/Internal/FFI/ModuleC.cpp src/LLVM/Internal/FFI/OrcJITC.cpp + src/LLVM/Internal/FFI/PassesC.cpp src/LLVM/Internal/FFI/RawOStreamC.cpp - src/LLVM/Internal/FFI/PassManagerC.cpp src/LLVM/Internal/FFI/RTDyldMemoryManager.cpp src/LLVM/Internal/FFI/SMDiagnosticC.cpp src/LLVM/Internal/FFI/TargetC.cpp @@ -277,6 +278,7 @@ test-suite test transformers >= 0.3.0.0, temporary >= 1.2 && < 1.4, pretty-show >= 1.6, + directory >= 1.3 && < 1.4, process, temporary hs-source-dirs: test diff --git a/llvm-hs/src/LLVM/Internal/Attribute.hs b/llvm-hs/src/LLVM/Internal/Attribute.hs index 096379cc..0b4dd8ee 100644 --- a/llvm-hs/src/LLVM/Internal/Attribute.hs +++ b/llvm-hs/src/LLVM/Internal/Attribute.hs @@ -20,7 +20,9 @@ import Foreign.Ptr import Data.Maybe import qualified LLVM.Internal.FFI.Attribute as FFI +import qualified LLVM.Internal.FFI.Context as FFI import qualified LLVM.Internal.FFI.LLVMCTypes as FFI +import LLVM.Internal.Type () import LLVM.Internal.FFI.LLVMCTypes (parameterAttributeKindP, functionAttributeKindP) import qualified LLVM.AST.ParameterAttribute as A.PA @@ -40,30 +42,40 @@ instance Monad m => EncodeM m A.PA.ParameterAttribute (Ptr FFI.ParameterAttrBuil (kindP, kindLen) <- encodeM kind (valueP, valueLen) <- encodeM value liftIO $ FFI.attrBuilderAddStringAttribute b kindP kindLen valueP valueLen + encodeM (A.PA.ByVal t) = return $ \b -> do + ty <- encodeM t + liftIO $ FFI.attrBuilderAddParameterTypeAttribute b FFI.parameterAttributeKindByVal ty + encodeM (A.PA.InAlloca t) = return $ \b -> do + ty <- encodeM t + liftIO $ FFI.attrBuilderAddParameterTypeAttribute b FFI.parameterAttributeKindInAlloca ty + encodeM (A.PA.SRet t) = return $ \b -> do + ty <- encodeM t + liftIO $ FFI.attrBuilderAddParameterTypeAttribute b FFI.parameterAttributeKindStructRet ty encodeM a = return $ \b -> liftIO $ case a of A.PA.Alignment v -> FFI.attrBuilderAddAlignment b v A.PA.Dereferenceable v -> FFI.attrBuilderAddDereferenceable b v A.PA.DereferenceableOrNull v -> FFI.attrBuilderAddDereferenceableOrNull b v _ -> FFI.attrBuilderAddParameterAttributeKind b $ case a of - A.PA.ByVal -> FFI.parameterAttributeKindByVal A.PA.ImmArg -> FFI.parameterAttributeKindImmArg - A.PA.InAlloca -> FFI.parameterAttributeKindInAlloca A.PA.InReg -> FFI.parameterAttributeKindInReg A.PA.Nest -> FFI.parameterAttributeKindNest A.PA.NoAlias -> FFI.parameterAttributeKindNoAlias A.PA.NoCapture -> FFI.parameterAttributeKindNoCapture A.PA.NoFree -> FFI.parameterAttributeKindNoFree + A.PA.NoUndef -> FFI.parameterAttributeKindNoUndef A.PA.NonNull -> FFI.parameterAttributeKindNonNull A.PA.ReadNone -> FFI.parameterAttributeKindReadNone A.PA.ReadOnly -> FFI.parameterAttributeKindReadOnly A.PA.Returned -> FFI.parameterAttributeKindReturned A.PA.SignExt -> FFI.parameterAttributeKindSExt - A.PA.SRet -> FFI.parameterAttributeKindStructRet A.PA.SwiftError -> FFI.parameterAttributeKindSwiftError A.PA.SwiftSelf -> FFI.parameterAttributeKindSwiftSelf A.PA.WriteOnly -> FFI.parameterAttributeKindWriteOnly A.PA.ZeroExt -> FFI.parameterAttributeKindZExt #if __GLASGOW_HASKELL__ < 900 + A.PA.ByVal _ -> inconsistentCases "ParameterAttribute" a + A.PA.InAlloca _ -> inconsistentCases "ParameterAttribute" a + A.PA.SRet _ -> inconsistentCases "ParameterAttribute" a A.PA.Alignment _ -> inconsistentCases "ParameterAttribute" a A.PA.Dereferenceable _ -> inconsistentCases "ParameterAttribute" a A.PA.DereferenceableOrNull _ -> inconsistentCases "ParameterAttribute" a @@ -80,13 +92,19 @@ instance Monad m => EncodeM m A.FA.FunctionAttribute (Ptr FFI.FunctionAttrBuilde x' <- encodeM x y' <- encodeM y liftIO $ FFI.attrBuilderAddAllocSize b x' y' + A.FA.VScaleRange vsMin vsMax -> do + vsMin' <- encodeM vsMin + vsMax' <- encodeM vsMax + liftIO $ FFI.attrBuilderAddVScaleRange b vsMin' vsMax' A.FA.StackAlignment v -> liftIO $ FFI.attrBuilderAddStackAlignment b v + A.FA.UWTable -> liftIO $ FFI.attrBuilderAddUWTable b _ -> liftIO $ FFI.attrBuilderAddFunctionAttributeKind b $ case a of A.FA.AlwaysInline -> FFI.functionAttributeKindAlwaysInline A.FA.ArgMemOnly -> FFI.functionAttributeKindArgMemOnly A.FA.Builtin -> FFI.functionAttributeKindBuiltin A.FA.Cold -> FFI.functionAttributeKindCold A.FA.Convergent -> FFI.functionAttributeKindConvergent + A.FA.Hot -> FFI.functionAttributeKindHot A.FA.InaccessibleMemOnly -> FFI.functionAttributeKindInaccessibleMemOnly A.FA.InaccessibleMemOrArgMemOnly -> FFI.functionAttributeKindInaccessibleMemOrArgMemOnly A.FA.InlineHint -> FFI.functionAttributeKindInlineHint @@ -95,16 +113,22 @@ instance Monad m => EncodeM m A.FA.FunctionAttribute (Ptr FFI.FunctionAttrBuilde A.FA.MustProgress -> FFI.functionAttributeKindMustProgress A.FA.Naked -> FFI.functionAttributeKindNaked A.FA.NoBuiltin -> FFI.functionAttributeKindNoBuiltin + A.FA.NoCallback -> FFI.functionAttributeKindNoCallback + A.FA.NoCfCheck -> FFI.functionAttributeKindNoCfCheck A.FA.NoDuplicate -> FFI.functionAttributeKindNoDuplicate A.FA.NoFree -> FFI.functionAttributeKindNoFree A.FA.NoImplicitFloat -> FFI.functionAttributeKindNoImplicitFloat A.FA.NoInline -> FFI.functionAttributeKindNoInline - A.FA.NonLazyBind -> FFI.functionAttributeKindNonLazyBind + A.FA.NoMerge -> FFI.functionAttributeKindNoMerge + A.FA.NoProfile -> FFI.functionAttributeKindNoProfile A.FA.NoRecurse -> FFI.functionAttributeKindNoRecurse A.FA.NoRedZone -> FFI.functionAttributeKindNoRedZone A.FA.NoReturn -> FFI.functionAttributeKindNoReturn A.FA.NoSync -> FFI.functionAttributeKindNoSync A.FA.NoUnwind -> FFI.functionAttributeKindNoUnwind + A.FA.NonLazyBind -> FFI.functionAttributeKindNonLazyBind + A.FA.NullPointerIsValid -> FFI.functionAttributeKindNullPointerIsValid + A.FA.OptForFuzzing -> FFI.functionAttributeKindOptForFuzzing A.FA.OptimizeForSize -> FFI.functionAttributeKindOptimizeForSize A.FA.OptimizeNone -> FFI.functionAttributeKindOptimizeNone A.FA.ReadNone -> FFI.functionAttributeKindReadNone @@ -113,20 +137,24 @@ instance Monad m => EncodeM m A.FA.FunctionAttribute (Ptr FFI.FunctionAttrBuilde A.FA.SafeStack -> FFI.functionAttributeKindSafeStack A.FA.SanitizeAddress -> FFI.functionAttributeKindSanitizeAddress A.FA.SanitizeHWAddress -> FFI.functionAttributeKindSanitizeHWAddress + A.FA.SanitizeMemTag -> FFI.functionAttributeKindSanitizeMemTag A.FA.SanitizeMemory -> FFI.functionAttributeKindSanitizeMemory A.FA.SanitizeThread -> FFI.functionAttributeKindSanitizeThread + A.FA.ShadowCallStack -> FFI.functionAttributeKindShadowCallStack A.FA.Speculatable -> FFI.functionAttributeKindSpeculatable + A.FA.SpeculativeLoadHardening -> FFI.functionAttributeKindSpeculativeLoadHardening A.FA.StackProtect -> FFI.functionAttributeKindStackProtect A.FA.StackProtectReq -> FFI.functionAttributeKindStackProtectReq A.FA.StackProtectStrong -> FFI.functionAttributeKindStackProtectStrong A.FA.StrictFP -> FFI.functionAttributeKindStrictFP - A.FA.UWTable -> FFI.functionAttributeKindUWTable A.FA.WillReturn -> FFI.functionAttributeKindWillReturn A.FA.WriteOnly -> FFI.functionAttributeKindWriteOnly #if __GLASGOW_HASKELL__ < 900 + A.FA.UWTable -> inconsistentCases "FunctionAttribute" a A.FA.AllocSize _ _ -> inconsistentCases "FunctionAttribute" a A.FA.StackAlignment _ -> inconsistentCases "FunctionAttribute" a A.FA.StringAttribute _ _ -> inconsistentCases "FunctionAttribute" a + A.FA.VScaleRange _ _ -> inconsistentCases "FunctionAttribute" a #endif instance DecodeM DecodeAST A.PA.ParameterAttribute FFI.ParameterAttribute where @@ -141,22 +169,23 @@ instance DecodeM DecodeAST A.PA.ParameterAttribute FFI.ParameterAttribute where enum <- liftIO $ FFI.parameterAttributeKindAsEnum a case enum of [parameterAttributeKindP|Alignment|] -> return A.PA.Alignment `ap` (liftIO $ FFI.attributeValueAsInt a) - [parameterAttributeKindP|ByVal|] -> return A.PA.ByVal + [parameterAttributeKindP|ByVal|] -> A.PA.ByVal <$> (decodeM =<< liftIO (FFI.attributeValueAsType a)) + [parameterAttributeKindP|InAlloca|] -> A.PA.InAlloca <$> (decodeM =<< liftIO (FFI.attributeValueAsType a)) + [parameterAttributeKindP|StructRet|] -> A.PA.SRet <$> (decodeM =<< liftIO (FFI.attributeValueAsType a)) [parameterAttributeKindP|DereferenceableOrNull|] -> return A.PA.DereferenceableOrNull `ap` (liftIO $ FFI.attributeValueAsInt a) [parameterAttributeKindP|Dereferenceable|] -> return A.PA.Dereferenceable `ap` (liftIO $ FFI.attributeValueAsInt a) [parameterAttributeKindP|ImmArg|] -> return A.PA.ImmArg - [parameterAttributeKindP|InAlloca|] -> return A.PA.InAlloca [parameterAttributeKindP|InReg|] -> return A.PA.InReg [parameterAttributeKindP|Nest|] -> return A.PA.Nest [parameterAttributeKindP|NoAlias|] -> return A.PA.NoAlias [parameterAttributeKindP|NoCapture|] -> return A.PA.NoCapture [parameterAttributeKindP|NoFree|] -> return A.PA.NoFree [parameterAttributeKindP|NonNull|] -> return A.PA.NonNull + [parameterAttributeKindP|NoUndef|] -> return A.PA.NoUndef [parameterAttributeKindP|ReadNone|] -> return A.PA.ReadNone [parameterAttributeKindP|ReadOnly|] -> return A.PA.ReadOnly [parameterAttributeKindP|Returned|] -> return A.PA.Returned [parameterAttributeKindP|SExt|] -> return A.PA.SignExt - [parameterAttributeKindP|StructRet|] -> return A.PA.SRet [parameterAttributeKindP|SwiftError|] -> return A.PA.SwiftError [parameterAttributeKindP|SwiftSelf|] -> return A.PA.SwiftSelf [parameterAttributeKindP|WriteOnly|] -> return A.PA.WriteOnly @@ -184,6 +213,7 @@ instance DecodeM DecodeAST A.FA.FunctionAttribute FFI.FunctionAttribute where [functionAttributeKindP|Builtin|] -> return A.FA.Builtin [functionAttributeKindP|Cold|] -> return A.FA.Cold [functionAttributeKindP|Convergent|] -> return A.FA.Convergent + [functionAttributeKindP|Hot|] -> return A.FA.Hot [functionAttributeKindP|InaccessibleMemOnly|] -> return A.FA.InaccessibleMemOnly [functionAttributeKindP|InaccessibleMemOrArgMemOnly|] -> return A.FA.InaccessibleMemOrArgMemOnly [functionAttributeKindP|InlineHint|] -> return A.FA.InlineHint @@ -192,16 +222,22 @@ instance DecodeM DecodeAST A.FA.FunctionAttribute FFI.FunctionAttribute where [functionAttributeKindP|MustProgress|] -> return A.FA.MustProgress [functionAttributeKindP|Naked|] -> return A.FA.Naked [functionAttributeKindP|NoBuiltin|] -> return A.FA.NoBuiltin + [functionAttributeKindP|NoCallback|] -> return A.FA.NoCallback + [functionAttributeKindP|NoCfCheck|] -> return A.FA.NoCfCheck [functionAttributeKindP|NoDuplicate|] -> return A.FA.NoDuplicate [functionAttributeKindP|NoFree|] -> return A.FA.NoFree [functionAttributeKindP|NoImplicitFloat|] -> return A.FA.NoImplicitFloat [functionAttributeKindP|NoInline|] -> return A.FA.NoInline + [functionAttributeKindP|NoMerge|] -> return A.FA.NoMerge + [functionAttributeKindP|NoProfile|] -> return A.FA.NoProfile [functionAttributeKindP|NoRecurse|] -> return A.FA.NoRecurse [functionAttributeKindP|NoRedZone|] -> return A.FA.NoRedZone [functionAttributeKindP|NoReturn|] -> return A.FA.NoReturn [functionAttributeKindP|NoSync|] -> return A.FA.NoSync [functionAttributeKindP|NoUnwind|] -> return A.FA.NoUnwind [functionAttributeKindP|NonLazyBind|] -> return A.FA.NonLazyBind + [functionAttributeKindP|NullPointerIsValid|] -> return A.FA.NullPointerIsValid + [functionAttributeKindP|OptForFuzzing|] -> return A.FA.OptForFuzzing [functionAttributeKindP|OptimizeForSize|] -> return A.FA.OptimizeForSize [functionAttributeKindP|OptimizeNone|] -> return A.FA.OptimizeNone [functionAttributeKindP|ReadNone|] -> return A.FA.ReadNone @@ -210,24 +246,34 @@ instance DecodeM DecodeAST A.FA.FunctionAttribute FFI.FunctionAttribute where [functionAttributeKindP|SafeStack|] -> return A.FA.SafeStack [functionAttributeKindP|SanitizeAddress|] -> return A.FA.SanitizeAddress [functionAttributeKindP|SanitizeHWAddress|] -> return A.FA.SanitizeHWAddress + [functionAttributeKindP|SanitizeMemTag|] -> return A.FA.SanitizeMemTag [functionAttributeKindP|SanitizeMemory|] -> return A.FA.SanitizeMemory [functionAttributeKindP|SanitizeThread|] -> return A.FA.SanitizeThread + [functionAttributeKindP|ShadowCallStack|] -> return A.FA.ShadowCallStack [functionAttributeKindP|Speculatable|] -> return A.FA.Speculatable + [functionAttributeKindP|SpeculativeLoadHardening|] -> return A.FA.SpeculativeLoadHardening [functionAttributeKindP|StackAlignment|] -> return A.FA.StackAlignment `ap` (liftIO $ FFI.attributeValueAsInt a) [functionAttributeKindP|StackProtectReq|] -> return A.FA.StackProtectReq [functionAttributeKindP|StackProtectStrong|] -> return A.FA.StackProtectStrong [functionAttributeKindP|StackProtect|] -> return A.FA.StackProtect [functionAttributeKindP|StrictFP|] -> return A.FA.StrictFP - [functionAttributeKindP|UWTable|] -> return A.FA.UWTable + [functionAttributeKindP|UWTable|] -> do + liftIO $ FFI.attributeEnsureUWTableKindDefault a + return A.FA.UWTable [functionAttributeKindP|WillReturn|] -> return A.FA.WillReturn [functionAttributeKindP|WriteOnly|] -> return A.FA.WriteOnly + [functionAttributeKindP|VScaleRange|] -> do + vsMin <- alloca + vsMax <- alloca + liftIO $ FFI.attributeGetVScaleRangeArgs a vsMin vsMax + A.FA.VScaleRange <$> (decodeM =<< peek vsMin) <*> (decodeM =<< peek vsMax) _ -> error $ "unhandled function attribute enum value: " ++ show enum -allocaAttrBuilder :: (Monad m, MonadAnyCont IO m) => m (Ptr (FFI.AttrBuilder a)) -allocaAttrBuilder = do +allocaAttrBuilder :: (Monad m, MonadAnyCont IO m) => Ptr (FFI.Context) -> m (Ptr (FFI.AttrBuilder a)) +allocaAttrBuilder (context) = do p <- allocaArray FFI.getAttrBuilderSize anyContToM $ \f -> do - ab <- FFI.constructAttrBuilder p + ab <- FFI.constructAttrBuilder context p r <- f ab FFI.destroyAttrBuilder ab return r @@ -235,10 +281,10 @@ allocaAttrBuilder = 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 + Context context <- gets encodeStateContext + ab <- allocaAttrBuilder context builds <- mapM encodeM as void (forM builds ($ ab) :: EncodeAST [()]) - Context context <- gets encodeStateContext anyContToM (bracket (FFI.getAttributeSet context ab) FFI.disposeAttributeSet) @@ -264,17 +310,17 @@ data PreSlot instance {-# OVERLAPPING #-} EncodeM EncodeAST [Either A.FA.GroupID A.FA.FunctionAttribute] FFI.FunctionAttributeSet where encodeM attrs = do - ab <- allocaAttrBuilder + Context context <- gets encodeStateContext + ab <- allocaAttrBuilder context forM_ attrs $ \attr -> case attr of Left groupId -> do attrSet <- referAttributeGroup groupId - ab' <- anyContToM (bracket (FFI.attrBuilderFromSet attrSet) FFI.disposeAttrBuilder) + ab' <- anyContToM (bracket (FFI.attrBuilderFromSet context attrSet) FFI.disposeAttrBuilder) liftIO (FFI.mergeAttrBuilder ab ab') Right attr -> do addAttr <- encodeM attr addAttr ab :: EncodeAST () - Context context <- gets encodeStateContext anyContToM (bracket (FFI.getAttributeSet context ab) FFI.disposeAttributeSet) diff --git a/llvm-hs/src/LLVM/Internal/Constant.hs b/llvm-hs/src/LLVM/Internal/Constant.hs index 17f7aacb..035ff69e 100644 --- a/llvm-hs/src/LLVM/Internal/Constant.hs +++ b/llvm-hs/src/LLVM/Internal/Constant.hs @@ -47,8 +47,7 @@ import LLVM.Internal.DecodeAST import LLVM.Internal.EncodeAST import LLVM.Internal.FloatingPointPredicate () import LLVM.Internal.IntegerPredicate () -import LLVM.Internal.Type (renameType) -import LLVM.Internal.Value +import LLVM.Internal.Type () allocaWords :: forall a m . (Storable a, MonadAnyCont IO m, Monad m, MonadIO m) => Word32 -> m (Ptr a) allocaWords nBits = do @@ -96,15 +95,7 @@ instance EncodeM EncodeAST A.Constant (Ptr FFI.Constant) where A.F.PPC_FP128 _ _ -> FFI.floatSemanticsPPCDoubleDouble nBits <- encodeM nBits liftIO $ FFI.constantFloatOfArbitraryPrecision context nBits words fpSem - A.C.GlobalReference ty n -> do - ref <- FFI.upCast <$> referGlobal n - ty' <- (liftIO . runDecodeAST . typeOf) ref - renamedTy <- renameType ty - if renamedTy /= ty' - then throwM - (EncodeException - ("The serialized GlobalReference " ++ show n ++ " has type " ++ show ty ++ " but should have type " ++ show ty')) - else return ref + A.C.GlobalReference n -> FFI.upCast <$> referGlobal n A.C.BlockAddress f b -> do f' <- referGlobal f b' <- getBlockForAddress f b @@ -204,9 +195,7 @@ instance DecodeM DecodeAST A.Constant (Ptr FFI.Constant) where t <- decodeM ft valueSubclassId <- liftIO $ FFI.getValueSubclassId v nOps <- liftIO $ FFI.getNumOperands u - let globalRef = return A.C.GlobalReference - `ap` (return t) - `ap` (getGlobalName =<< liftIO (FFI.isAGlobalValue v)) + let globalRef = A.C.GlobalReference <$> (getGlobalName =<< liftIO (FFI.isAGlobalValue v)) op = decodeM <=< liftIO . FFI.getConstantOperand c getConstantOperands = mapM op [0..nOps-1] getConstantData = do @@ -281,6 +270,8 @@ instance DecodeM DecodeAST A.Constant (Ptr FFI.Constant) where operandNumber <- get modify (+1) return [| op $(TH.litE . TH.integerL $ operandNumber) |] + | h == ''A.Type && n == 'A.C.GetElementPtr -> + return [| decodeM =<< liftIO (FFI.getConstantGEPSourceType c) |] | h == ''A.Type -> return [| pure t |] | h == ''A.IntegerPredicate -> return [| liftIO $ decodeM =<< FFI.getConstantICmpPredicate c |] @@ -293,14 +284,6 @@ instance DecodeM DecodeAST A.Constant (Ptr FFI.Constant) where "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 diff --git a/llvm-hs/src/LLVM/Internal/Context.hs b/llvm-hs/src/LLVM/Internal/Context.hs index e2352cd3..5b89ec03 100644 --- a/llvm-hs/src/LLVM/Internal/Context.hs +++ b/llvm-hs/src/LLVM/Internal/Context.hs @@ -14,14 +14,20 @@ import qualified LLVM.Internal.FFI.Context as FFI -- | Then it got packed up in this object to allow multiple threads to compile at once. data Context = Context (Ptr FFI.Context) +contextCreate :: IO (Ptr FFI.Context) +contextCreate = do + ctx <- FFI.contextCreate + FFI.contextSetOpaquePointers ctx + return ctx + -- | Create a Context, run an action (to which it is provided), then destroy the Context. withContext :: (Context -> IO a) -> IO a -withContext = runBound . bracket FFI.contextCreate FFI.contextDispose . (. Context) +withContext = runBound . bracket contextCreate FFI.contextDispose . (. Context) where runBound = if rtsSupportsBoundThreads then runInBoundThread else id -- | Create a Context. createContext :: IO Context -createContext = Context <$> FFI.contextCreate +createContext = Context <$> contextCreate -- | Destroy a context created by 'createContext'. disposeContext :: Context -> IO () diff --git a/llvm-hs/src/LLVM/Internal/FFI/Attribute.h b/llvm-hs/src/LLVM/Internal/FFI/Attribute.h index 61f84a36..2f12fa01 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/Attribute.h +++ b/llvm-hs/src/LLVM/Internal/FFI/Attribute.h @@ -4,22 +4,26 @@ // The last three arguments are flags indicating if this is a // parameter attribute, function result attribute or function attribute. -#define LLVM_HS_FOR_EACH_ATTRIBUTE_KIND(macro) \ +#define LLVM_HS_FOR_EACH_ATTRIBUTE_KIND(macro) \ macro(None,F,F,F) \ + macro(AllocAlign,T,F,F) \ + macro(AllocatedPointer,T,F,F) \ macro(AlwaysInline,F,F,T) \ macro(ArgMemOnly,F,F,T) \ macro(Builtin,F,F,T) \ macro(Cold,F,F,T) \ macro(Convergent,F,F,T) \ + macro(DisableSanitizerInstrumentation,F,F,T) \ + macro(FnRetThunkExtern,F,F,T) \ macro(Hot,F,F,T) \ macro(ImmArg,T,F,F) \ - macro(InAlloca,T,F,F) \ macro(InReg,T,T,F) \ macro(InaccessibleMemOnly,F,F,T) \ macro(InaccessibleMemOrArgMemOnly,F,F,T) \ macro(InlineHint,F,F,T) \ macro(JumpTable,F,F,T) \ macro(MinSize,F,F,T) \ + macro(MustProgress,F,F,T) \ macro(Naked,F,F,T) \ macro(Nest,T,F,F) \ macro(NoAlias,T,T,F) \ @@ -36,15 +40,18 @@ macro(NoRecurse,F,F,T) \ macro(NoRedZone,F,F,T) \ macro(NoReturn,F,F,T) \ + macro(NoSanitizeBounds,F,F,T) \ + macro(NoSanitizeCoverage,F,F,T) \ macro(NoSync,F,F,T) \ - macro(NoUndef,F,F,T) \ + macro(NoUndef,T,F,T) \ macro(NoUnwind,F,F,T) \ macro(NonLazyBind,F,F,T) \ macro(NonNull,T,T,F) \ - macro(NullPointerIsValid,T,T,F) \ + macro(NullPointerIsValid,F,F,T) \ macro(OptForFuzzing,F,F,T) \ macro(OptimizeForSize,F,F,T) \ macro(OptimizeNone,F,F,T) \ + macro(PresplitCoroutine,F,F,T) \ macro(ReadNone,T,F,T) \ macro(ReadOnly,T,F,T) \ macro(Returned,T,F,F) \ @@ -57,28 +64,33 @@ macro(SanitizeMemory,F,F,T) \ macro(SanitizeThread,F,F,T) \ macro(ShadowCallStack,F,F,T) \ + macro(SkipProfile,F,F,T) \ macro(Speculatable,F,F,T) \ macro(SpeculativeLoadHardening,F,F,T) \ macro(StackProtect,F,F,T) \ macro(StackProtectReq,F,F,T) \ macro(StackProtectStrong,F,F,T) \ macro(StrictFP,F,F,T) \ + macro(SwiftAsync,T,F,F) \ macro(SwiftError,T,F,F) \ macro(SwiftSelf,T,F,F) \ - macro(UWTable,F,F,T) \ macro(WillReturn,F,F,T) \ macro(WriteOnly,T,F,T) \ macro(ZExt,T,T,F) \ macro(ByRef,T,F,F) \ macro(ByVal,T,F,F) \ - macro(MustProgress,F,F,T) \ + macro(ElementType,T,F,F) \ + macro(InAlloca,T,F,F) \ macro(Preallocated,F,F,T) \ macro(StructRet,T,F,F) \ macro(Alignment,T,T,F) \ + macro(AllocKind,F,F,T) \ macro(AllocSize,F,F,T) \ macro(Dereferenceable,T,T,F) \ macro(DereferenceableOrNull,T,T,F) \ macro(StackAlignment,F,F,T) \ + macro(UWTable,F,F,T) \ + macro(VScaleRange,F,F,T) \ macro(EndAttrKinds,F,F,F) typedef enum { diff --git a/llvm-hs/src/LLVM/Internal/FFI/Attribute.hs b/llvm-hs/src/LLVM/Internal/FFI/Attribute.hs index 1a5a8917..fad9edd7 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/Attribute.hs +++ b/llvm-hs/src/LLVM/Internal/FFI/Attribute.hs @@ -11,6 +11,7 @@ import Foreign.Ptr import LLVM.Internal.FFI.Context import LLVM.Internal.FFI.LLVMCTypes +import LLVM.Internal.FFI.PtrHierarchy type Slot = CUInt type IntValue = Word64 @@ -87,7 +88,12 @@ foreign import ccall unsafe "LLVM_Hs_AttributeValueAsString" attributeValueAsStr foreign import ccall unsafe "LLVM_Hs_AttributeValueAsInt" attributeValueAsInt :: Attribute a -> IO Word64 --- | The LLVM C API does not expose this functionality +foreign import ccall unsafe "LLVM_Hs_AttributeEnsureUWTableKindDefault" attributeEnsureUWTableKindDefault :: + Attribute a -> IO () + +foreign import ccall unsafe "LLVM_Hs_AttributeValueAsType" attributeValueAsType :: + Attribute a -> IO (Ptr Type) + foreign import ccall unsafe "LLVM_Hs_getNumAttributes" getNumAttributes :: AttributeSet a -> IO CUInt @@ -123,7 +129,7 @@ foreign import ccall unsafe "LLVM_Hs_GetAttrBuilderSize" getAttrBuilderSize :: CSize foreign import ccall unsafe "LLVM_Hs_AttrBuilderFromAttrSet" attrBuilderFromSet :: - AttributeSet a -> IO (Ptr (AttrBuilder a)) + Ptr Context -> AttributeSet a -> IO (Ptr (AttrBuilder a)) foreign import ccall unsafe "LLVM_Hs_DisposeAttrBuilder" disposeAttrBuilder :: Ptr (AttrBuilder a) -> IO () @@ -132,7 +138,7 @@ 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)) + Ptr Context -> Ptr Word8 -> IO (Ptr (AttrBuilder a)) foreign import ccall unsafe "LLVM_Hs_DestroyAttrBuilder" destroyAttrBuilder :: Ptr (AttrBuilder a) -> IO () @@ -143,6 +149,9 @@ foreign import ccall unsafe "LLVM_Hs_AttrBuilderAddAttributeKind" attrBuilderAdd foreign import ccall unsafe "LLVM_Hs_AttrBuilderAddAttributeKind" attrBuilderAddParameterAttributeKind :: Ptr ParameterAttrBuilder -> ParameterAttributeKind -> IO () +foreign import ccall unsafe "LLVM_Hs_AttrBuilderAddTypeAttribute" attrBuilderAddParameterTypeAttribute :: + Ptr ParameterAttrBuilder -> ParameterAttributeKind -> Ptr Type -> IO () + foreign import ccall unsafe "LLVM_Hs_AttrBuilderAddStringAttribute" attrBuilderAddStringAttribute :: Ptr (AttrBuilder a) -> Ptr CChar -> CSize -> Ptr CChar -> CSize -> IO () @@ -152,6 +161,9 @@ foreign import ccall unsafe "LLVM_Hs_AttrBuilderAddAlignment" attrBuilderAddAlig foreign import ccall unsafe "LLVM_Hs_AttrBuilderAddStackAlignment" attrBuilderAddStackAlignment :: Ptr FunctionAttrBuilder -> Word64 -> IO () +foreign import ccall unsafe "LLVM_Hs_AttrBuilderAddUWTable" attrBuilderAddUWTable :: + Ptr FunctionAttrBuilder -> IO () + -- The CInt is 0 if the last value is null and 1 otherwise foreign import ccall unsafe "LLVM_Hs_AttrBuilderAddAllocSize" attrBuilderAddAllocSize' :: Ptr FunctionAttrBuilder -> CUInt -> CUInt -> LLVMBool -> IO () @@ -167,3 +179,9 @@ foreign import ccall unsafe "LLVM_Hs_AttrBuilderAddDereferenceableOrNullAttr" at foreign import ccall unsafe "LLVM_Hs_AttributeGetAllocSizeArgs" attributeGetAllocSizeArgs :: FunctionAttribute -> Ptr CUInt -> Ptr CUInt -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_AttributeGetVScaleRangeArgs" attributeGetVScaleRangeArgs :: + FunctionAttribute -> Ptr CUInt -> Ptr CUInt -> IO () + +foreign import ccall unsafe "LLVM_Hs_AttrBuilderAddVScaleRange" attrBuilderAddVScaleRange :: + Ptr FunctionAttrBuilder -> CUInt -> CUInt -> IO () diff --git a/llvm-hs/src/LLVM/Internal/FFI/AttributeC.cpp b/llvm-hs/src/LLVM/Internal/FFI/AttributeC.cpp index b70761ff..05346ea4 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/AttributeC.cpp +++ b/llvm-hs/src/LLVM/Internal/FFI/AttributeC.cpp @@ -1,7 +1,11 @@ #define __STDC_LIMIT_MACROS +#include "llvm-c/Core.h" +#include "llvm/IR/DerivedTypes.h" #include "LLVM/Internal/FFI/AttributeC.hpp" #include "llvm/IR/LLVMContext.h" +#include + extern "C" { static_assert(sizeof(AttributeList) == sizeof(AttributeListImpl *), @@ -22,6 +26,18 @@ uint64_t LLVM_Hs_AttributeValueAsInt(LLVMAttributeRef a) { return unwrap(a).getValueAsInt(); } +void LLVM_Hs_AttributeEnsureUWTableKindDefault(LLVMAttributeRef a) { + assert(unwrap(a).getUWTableKind() == UWTableKind::Default); +} + +LLVMTypeRef LLVM_Hs_AttributeValueAsType(LLVMAttributeRef a) { + return wrap(unwrap(a).getValueAsType()); +} + +LLVMBool LLVM_Hs_IsStringAttribute(LLVMAttributeRef a) { + return unwrap(a).isStringAttribute(); +} + const char *LLVM_Hs_AttributeKindAsString(LLVMAttributeRef a, size_t &l) { const StringRef s = unwrap(a).getKindAsString(); l = s.size(); @@ -88,15 +104,15 @@ void LLVM_Hs_getAttributes(AttributeSet *attributeSet, size_t LLVM_Hs_GetAttrBuilderSize() { return sizeof(AttrBuilder); } -AttrBuilder *LLVM_Hs_ConstructAttrBuilder(char *p) { - return new (p) AttrBuilder(); +AttrBuilder *LLVM_Hs_ConstructAttrBuilder(LLVMContextRef context, char *p) { + return new (p) AttrBuilder(*unwrap(context)); } -AttrBuilder *LLVM_Hs_AttrBuilderFromAttrSet(AttributeSet *as) { - return new AttrBuilder(*as); +AttrBuilder *LLVM_Hs_AttrBuilderFromAttrSet(LLVMContextRef context, LLVMAttributeSetRef as) { + return new AttrBuilder(*unwrap(context), *as); } -void LLVM_Hs_DisposeAttrBuilder(AttributeSet *as) { delete as; } +void LLVM_Hs_DisposeAttrBuilder(AttrBuilder *as) { delete as; } void LLVM_Hs_AttrBuilderMerge(AttrBuilder *ab1, AttrBuilder *ab2) { ab1->merge(*ab2); @@ -108,6 +124,10 @@ void LLVM_Hs_AttrBuilderAddAttributeKind(AttrBuilder &ab, unsigned kind) { ab.addAttribute(Attribute::AttrKind(kind)); } +void LLVM_Hs_AttrBuilderAddTypeAttribute(AttrBuilder &ab, unsigned kind, LLVMTypeRef t) { + ab.addTypeAttr(Attribute::AttrKind(kind), unwrap(t)); +} + void LLVM_Hs_AttrBuilderAddStringAttribute(AttrBuilder &ab, const char *kind, size_t kind_len, const char *value, size_t value_len) { @@ -122,6 +142,10 @@ void LLVM_Hs_AttrBuilderAddStackAlignment(AttrBuilder &ab, uint64_t v) { ab.addStackAlignmentAttr(MaybeAlign(v)); } +void LLVM_Hs_AttrBuilderAddUWTable(AttrBuilder &ab) { + ab.addUWTableAttr(UWTableKind::Default); +} + void LLVM_Hs_AttrBuilderAddAllocSize(AttrBuilder &ab, unsigned x, unsigned y, LLVMBool optionalIsThere) { if (optionalIsThere) { @@ -144,11 +168,21 @@ LLVMBool LLVM_Hs_AttributeGetAllocSizeArgs(LLVMAttributeRef a, unsigned *x, unsigned *y) { auto pair = unwrap(a).getAllocSizeArgs(); *x = pair.first; - if (pair.second.hasValue()) { - *y = pair.second.getValue(); + if (pair.second.has_value()) { + *y = pair.second.value(); return 1; } else { return 0; } } + +void LLVM_Hs_AttributeGetVScaleRangeArgs(LLVMAttributeRef a, unsigned *min, unsigned *max) { + *min = unwrap(a).getVScaleRangeMin(); + *max = unwrap(a).getVScaleRangeMax().value_or(0); +} + +void LLVM_Hs_AttrBuilderAddVScaleRange(AttrBuilder &ab, unsigned min, unsigned max) { + ab.addVScaleRangeAttr(min, max); +} + } diff --git a/llvm-hs/src/LLVM/Internal/FFI/Builder.hs b/llvm-hs/src/LLVM/Internal/FFI/Builder.hs index 8434e55d..0626c09a 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/Builder.hs +++ b/llvm-hs/src/LLVM/Internal/FFI/Builder.hs @@ -9,12 +9,6 @@ import Foreign.Ptr import Foreign.C import GHC.Stack -import qualified Data.List as List -import qualified Data.Map as Map - -import qualified LLVM.AST.Instruction as A -import LLVM.Internal.InstructionDefs as ID - import LLVM.Internal.FFI.Context import LLVM.Internal.FFI.LLVMCTypes import LLVM.Internal.FFI.PtrHierarchy @@ -45,8 +39,8 @@ foreign import ccall unsafe "LLVMBuildSwitch" buildSwitch :: foreign import ccall unsafe "LLVMBuildIndirectBr" buildIndirectBr :: Ptr Builder -> Ptr Value -> CUInt -> IO (Ptr Instruction) -foreign import ccall unsafe "LLVMBuildInvoke" buildInvoke :: - Ptr Builder -> Ptr Value -> Ptr (Ptr Value) -> CUInt +foreign import ccall unsafe "LLVMBuildInvoke2" buildInvoke :: + Ptr Builder -> Ptr Type -> Ptr Value -> Ptr (Ptr Value) -> CUInt -> Ptr BasicBlock -> Ptr BasicBlock -> CString -> IO (Ptr Instruction) foreign import ccall unsafe "LLVMBuildResume" buildResume :: @@ -164,10 +158,10 @@ foreign import ccall unsafe "LLVMBuildArrayAlloca" buildAlloca :: Ptr Builder -> Ptr Type -> Ptr Value -> CString -> IO (Ptr Instruction) foreign import ccall unsafe "LLVM_Hs_BuildLoad" buildLoad' :: - Ptr Builder -> LLVMBool -> Ptr Value -> MemoryOrdering -> SynchronizationScope -> CUInt -> CString -> IO (Ptr Instruction) + Ptr Builder -> LLVMBool -> Ptr Type -> Ptr Value -> MemoryOrdering -> SynchronizationScope -> CUInt -> CString -> IO (Ptr Instruction) -buildLoad :: Ptr Builder -> LLVMBool -> Ptr Value -> (SynchronizationScope, MemoryOrdering) -> CUInt -> CString -> IO (Ptr Instruction) -buildLoad builder vol a' (ss, mo) al s = buildLoad' builder vol a' mo ss al s +buildLoad :: Ptr Builder -> LLVMBool -> Ptr Type -> Ptr Value -> (SynchronizationScope, MemoryOrdering) -> CUInt -> CString -> IO (Ptr Instruction) +buildLoad builder vol ty a' (ss, mo) al s = buildLoad' builder vol ty a' mo ss al s foreign import ccall unsafe "LLVM_Hs_BuildStore" buildStore' :: Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> MemoryOrdering -> SynchronizationScope -> CUInt -> CString -> IO (Ptr Instruction) @@ -176,15 +170,15 @@ buildStore :: Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> (Synchronizat buildStore builder vol a' v' (ss, mo) al s = buildStore' builder vol a' v' mo ss al s foreign import ccall unsafe "LLVM_Hs_BuildGEP" buildGetElementPtr' :: - Ptr Builder -> Ptr Value -> Ptr (Ptr Value) -> CUInt -> CString -> IO (Ptr Instruction) + Ptr Builder -> Ptr Type -> Ptr Value -> Ptr (Ptr Value) -> CUInt -> CString -> IO (Ptr Instruction) foreign import ccall unsafe "LLVM_Hs_BuildInBoundsGEP" buildInBoundsGetElementPtr' :: - Ptr Builder -> Ptr Value -> Ptr (Ptr Value) -> CUInt -> CString -> IO (Ptr Instruction) + Ptr Builder -> Ptr Type -> Ptr Value -> Ptr (Ptr Value) -> CUInt -> CString -> IO (Ptr Instruction) -buildGetElementPtr :: HasCallStack => 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) +buildGetElementPtr :: HasCallStack => Ptr Builder -> LLVMBool -> Ptr Type -> Ptr Value -> (CUInt, Ptr (Ptr Value)) -> CString -> IO (Ptr Instruction) +buildGetElementPtr builder (LLVMBool 1) ty a (n, is) s = buildInBoundsGetElementPtr' builder ty a is n s +buildGetElementPtr builder (LLVMBool 0) ty a (n, is) s = buildGetElementPtr' builder ty 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) @@ -193,16 +187,16 @@ buildFence :: Ptr Builder -> (SynchronizationScope, MemoryOrdering) -> CString - buildFence builder (ss, mo) s = buildFence' builder mo ss s foreign import ccall unsafe "LLVM_Hs_BuildAtomicCmpXchg" buildCmpXchg' :: - Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> Ptr Value -> MemoryOrdering -> MemoryOrdering -> SynchronizationScope -> CString -> IO (Ptr Instruction) + Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> Ptr Value -> CUInt -> MemoryOrdering -> MemoryOrdering -> SynchronizationScope -> CString -> IO (Ptr Instruction) -buildCmpXchg :: Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> Ptr Value -> (SynchronizationScope, MemoryOrdering) -> MemoryOrdering -> CString -> IO (Ptr Instruction) -buildCmpXchg builder vol a e r (ss, smo) fmo s = buildCmpXchg' builder vol a e r smo fmo ss s +buildCmpXchg :: Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> Ptr Value -> CUInt -> (SynchronizationScope, MemoryOrdering) -> MemoryOrdering -> CString -> IO (Ptr Instruction) +buildCmpXchg builder vol a e r al (ss, smo) fmo s = buildCmpXchg' builder vol a e r al smo fmo ss s foreign import ccall unsafe "LLVM_Hs_BuildAtomicRMW" buildAtomicRMW' :: - Ptr Builder -> LLVMBool -> RMWOperation -> Ptr Value -> Ptr Value -> MemoryOrdering -> SynchronizationScope -> CString -> IO (Ptr Instruction) + Ptr Builder -> LLVMBool -> RMWOperation -> Ptr Value -> Ptr Value -> CUInt -> MemoryOrdering -> SynchronizationScope -> CString -> IO (Ptr Instruction) -buildAtomicRMW :: Ptr Builder -> LLVMBool -> RMWOperation -> Ptr Value -> Ptr Value -> (SynchronizationScope, MemoryOrdering) -> CString -> IO (Ptr Instruction) -buildAtomicRMW builder vol rmwOp a v (ss, mo) s = buildAtomicRMW' builder vol rmwOp a v mo ss s +buildAtomicRMW :: Ptr Builder -> LLVMBool -> RMWOperation -> Ptr Value -> Ptr Value -> CUInt -> (SynchronizationScope, MemoryOrdering) -> CString -> IO (Ptr Instruction) +buildAtomicRMW builder vol rmwOp a v al (ss, mo) s = buildAtomicRMW' builder vol rmwOp a v al mo ss s foreign import ccall unsafe "LLVM_Hs_BuildICmp" buildICmp :: Ptr Builder -> ICmpPredicate -> Ptr Value -> Ptr Value -> CString -> IO (Ptr Instruction) @@ -213,8 +207,8 @@ foreign import ccall unsafe "LLVMBuildFCmp" buildFCmp :: foreign import ccall unsafe "LLVMBuildPhi" buildPhi :: Ptr Builder -> Ptr Type -> CString -> IO (Ptr Instruction) -foreign import ccall unsafe "LLVMBuildCall" buildCall :: - Ptr Builder -> Ptr Value -> Ptr (Ptr Value) -> CUInt -> CString -> IO (Ptr Instruction) +foreign import ccall unsafe "LLVMBuildCall2" buildCall :: + Ptr Builder -> Ptr Type -> Ptr Value -> Ptr (Ptr Value) -> CUInt -> CString -> IO (Ptr Instruction) foreign import ccall unsafe "LLVMBuildFreeze" buildFreeze :: Ptr Builder -> Ptr Value -> Ptr Type -> IO (Ptr Instruction) diff --git a/llvm-hs/src/LLVM/Internal/FFI/BuilderC.cpp b/llvm-hs/src/LLVM/Internal/FFI/BuilderC.cpp index 9c934716..d02c04bb 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/BuilderC.cpp +++ b/llvm-hs/src/LLVM/Internal/FFI/BuilderC.cpp @@ -51,7 +51,6 @@ LLVM_HS_FOR_EACH_FAST_MATH_FLAG(ENUM_CASE) #undef ENUM_CASE return r; } - } extern "C" { @@ -294,16 +293,18 @@ LLVMValueRef LLVM_Hs_BuildICmp(LLVMBuilderRef b, LLVMIntPredicate op, LLVMValueR LLVMValueRef LLVM_Hs_BuildLoad( LLVMBuilderRef b, LLVMBool isVolatile, + LLVMTypeRef ty, LLVMValueRef p, LLVMAtomicOrdering atomicOrdering, LLVMSynchronizationScope synchScope, unsigned align, const char *name ) { - LoadInst *i = unwrap(b)->CreateAlignedLoad(unwrap(p), MaybeAlign(align), isVolatile, name); - i->setOrdering(unwrap(atomicOrdering)); - if (atomicOrdering != LLVMAtomicOrderingNotAtomic) i->setSyncScopeID(unwrap(synchScope)); - return wrap(i); + LoadInst *i = unwrap(b)->CreateAlignedLoad( + unwrap(ty), unwrap(p), MaybeAlign(align), isVolatile, name); + i->setOrdering(unwrap(atomicOrdering)); + if (atomicOrdering != LLVMAtomicOrderingNotAtomic) i->setSyncScopeID(unwrap(synchScope)); + return wrap(i); } LLVMValueRef LLVM_Hs_BuildStore( @@ -316,11 +317,11 @@ LLVMValueRef LLVM_Hs_BuildStore( unsigned align, const char *name ) { - StoreInst *i = unwrap(b)->CreateAlignedStore(unwrap(v), unwrap(p), MaybeAlign(align), isVolatile); - i->setName(name); - i->setOrdering(unwrap(atomicOrdering)); - if (atomicOrdering != LLVMAtomicOrderingNotAtomic) i->setSyncScopeID(unwrap(synchScope)); - return wrap(i); + StoreInst *i = unwrap(b)->CreateAlignedStore(unwrap(v), unwrap(p), MaybeAlign(align), isVolatile); + i->setName(name); + i->setOrdering(unwrap(atomicOrdering)); + if (atomicOrdering != LLVMAtomicOrderingNotAtomic) i->setSyncScopeID(unwrap(synchScope)); + return wrap(i); } LLVMValueRef LLVM_Hs_BuildFence( @@ -332,40 +333,42 @@ LLVMValueRef LLVM_Hs_BuildFence( } LLVMValueRef LLVM_Hs_BuildAtomicCmpXchg( - LLVMBuilderRef b, - LLVMBool v, - LLVMValueRef ptr, - LLVMValueRef cmp, - LLVMValueRef n, - LLVMAtomicOrdering successOrdering, - LLVMAtomicOrdering failureOrdering, - LLVMSynchronizationScope lss, - const char *name + LLVMBuilderRef b, + LLVMBool v, + LLVMValueRef ptr, + LLVMValueRef cmp, + LLVMValueRef n, + unsigned align, + LLVMAtomicOrdering successOrdering, + LLVMAtomicOrdering failureOrdering, + LLVMSynchronizationScope lss, + const char *name ) { - AtomicCmpXchgInst *a = unwrap(b)->CreateAtomicCmpXchg( - unwrap(ptr), unwrap(cmp), unwrap(n), unwrap(successOrdering), unwrap(failureOrdering), unwrap(lss) - ); - a->setVolatile(v); - a->setName(name); - return wrap(a); + AtomicCmpXchgInst *a = unwrap(b)->CreateAtomicCmpXchg( + unwrap(ptr), unwrap(cmp), unwrap(n), MaybeAlign(align), unwrap(successOrdering), unwrap(failureOrdering), unwrap(lss) + ); + a->setVolatile(v); + a->setName(name); + return wrap(a); } LLVMValueRef LLVM_Hs_BuildAtomicRMW( - LLVMBuilderRef b, - LLVMBool v, - LLVMAtomicRMWBinOp_ rmwOp, - LLVMValueRef ptr, - LLVMValueRef val, - LLVMAtomicOrdering lao, - LLVMSynchronizationScope lss, - const char *name + LLVMBuilderRef b, + LLVMBool v, + LLVMAtomicRMWBinOp_ rmwOp, + LLVMValueRef ptr, + LLVMValueRef val, + unsigned align, + LLVMAtomicOrdering lao, + LLVMSynchronizationScope lss, + const char *name ) { - AtomicRMWInst *a = unwrap(b)->CreateAtomicRMW( - unwrap(rmwOp), unwrap(ptr), unwrap(val), unwrap(lao), unwrap(lss) - ); - a->setVolatile(v); - a->setName(name); - return wrap(a); + AtomicRMWInst *a = unwrap(b)->CreateAtomicRMW( + unwrap(rmwOp), unwrap(ptr), unwrap(val), MaybeAlign(align), unwrap(lao), unwrap(lss) + ); + a->setVolatile(v); + a->setName(name); + return wrap(a); } LLVMValueRef LLVM_Hs_BuildCleanupPad(LLVMBuilderRef b, LLVMValueRef parentPad, @@ -410,18 +413,24 @@ LLVMValueRef LLVM_Hs_BuildCatchSwitch(LLVMBuilderRef b, LLVMValueRef parentPad, unwrap(unwindDest), numHandlers)); } -LLVMValueRef LLVM_Hs_BuildGEP(LLVMBuilderRef B, LLVMValueRef Pointer, +LLVMValueRef LLVM_Hs_BuildGEP(LLVMBuilderRef B, LLVMTypeRef PointeeType, LLVMValueRef Pointer, LLVMValueRef *Indices, unsigned NumIndices, const char *Name) { ArrayRef IdxList(unwrap(Indices), NumIndices); - return wrap(unwrap(B)->Insert(GetElementPtrInst::Create(nullptr, unwrap(Pointer), IdxList), Name)); + return wrap( + unwrap(B)->Insert(GetElementPtrInst::Create(unwrap(PointeeType), + unwrap(Pointer), IdxList), + Name)); } -LLVMValueRef LLVM_Hs_BuildInBoundsGEP(LLVMBuilderRef B, LLVMValueRef Pointer, +LLVMValueRef LLVM_Hs_BuildInBoundsGEP(LLVMBuilderRef B, LLVMTypeRef PointeeType, LLVMValueRef Pointer, LLVMValueRef *Indices, unsigned NumIndices, const char *Name) { ArrayRef IdxList(unwrap(Indices), NumIndices); - return wrap(unwrap(B)->Insert(GetElementPtrInst::CreateInBounds(nullptr, unwrap(Pointer), IdxList), Name)); + return wrap( + unwrap(B)->Insert(GetElementPtrInst::CreateInBounds( + unwrap(PointeeType), unwrap(Pointer), IdxList), + Name)); } LLVMValueRef LLVM_Hs_BuildSelect(LLVMBuilderRef B, LLVMValueRef If, diff --git a/llvm-hs/src/LLVM/Internal/FFI/Constant.hs b/llvm-hs/src/LLVM/Internal/FFI/Constant.hs index ae46338e..3d48581c 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/Constant.hs +++ b/llvm-hs/src/LLVM/Internal/FFI/Constant.hs @@ -107,19 +107,22 @@ $(do foreignDecl (prefix ++ "Const" ++ name) ("constant" ++ name) (map typeMapping fieldTypes) [t| Ptr Constant |] ) -foreign import ccall unsafe "LLVMConstGEP" constantGetElementPtr' :: - Ptr Constant -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant) +foreign import ccall unsafe "LLVMConstGEP2" constantGetElementPtr' :: + Ptr Type -> Ptr Constant -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant) -foreign import ccall unsafe "LLVMConstInBoundsGEP" constantInBoundsGetElementPtr' :: - Ptr Constant -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant) +foreign import ccall unsafe "LLVMConstInBoundsGEP2" constantInBoundsGetElementPtr' :: + Ptr Type -> Ptr Constant -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant) -constantGetElementPtr :: LLVMBool -> Ptr Constant -> (CUInt, Ptr (Ptr Constant)) -> IO (Ptr Constant) -constantGetElementPtr (LLVMBool ib) a (n, is) = +constantGetElementPtr :: LLVMBool -> Ptr Type -> Ptr Constant -> (CUInt, Ptr (Ptr Constant)) -> IO (Ptr Constant) +constantGetElementPtr (LLVMBool ib) ty a (n, is) = (case ib of 0 -> constantGetElementPtr' 1 -> constantInBoundsGetElementPtr' _ -> error ("LLVMBool should be 0 or 1 but is " <> show ib) - ) a is n + ) ty a is n + +foreign import ccall unsafe "LLVM_Hs_GetConstGEPSourceType" getConstantGEPSourceType :: + Ptr Constant -> IO (Ptr Type) foreign import ccall unsafe "LLVM_Hs_GetConstCPPOpcode" getConstantCPPOpcode :: Ptr Constant -> IO CPPOpcode @@ -130,9 +133,6 @@ foreign import ccall unsafe "LLVM_Hs_GetConstPredicate" getConstantICmpPredicate foreign import ccall unsafe "LLVM_Hs_GetConstPredicate" getConstantFCmpPredicate :: Ptr Constant -> IO FCmpPredicate -foreign import ccall unsafe "LLVM_Hs_GetConstIndices" getConstantIndices :: - Ptr Constant -> Ptr CUInt -> IO (Ptr CUInt) - foreign import ccall unsafe "LLVMGetUndef" constantUndef :: Ptr Type -> IO (Ptr Constant) diff --git a/llvm-hs/src/LLVM/Internal/FFI/ConstantC.cpp b/llvm-hs/src/LLVM/Internal/FFI/ConstantC.cpp index d22c52ce..af201010 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/ConstantC.cpp +++ b/llvm-hs/src/LLVM/Internal/FFI/ConstantC.cpp @@ -2,6 +2,7 @@ #include "llvm/IR/LLVMContext.h" #include "llvm/IR/Constants.h" #include "llvm/IR/Function.h" +#include "llvm/IR/Operator.h" #include "llvm-c/Core.h" #include "LLVM/Internal/FFI/Value.h" @@ -68,14 +69,6 @@ LLVMValueRef LLVM_Hs_ConstSub(unsigned nsw, unsigned nuw, LLVMValueRef o0, LLVMV return wrap(ConstantExpr::getSub(unwrap(o0), unwrap(o1), nuw != 0, nsw != 0)); } -LLVMValueRef LLVM_Hs_ConstUDiv(unsigned isExact, LLVMValueRef o0, LLVMValueRef o1) { - return wrap(ConstantExpr::getUDiv(unwrap(o0), unwrap(o1), isExact != 0)); -} - -LLVMValueRef LLVM_Hs_ConstSDiv(unsigned isExact, LLVMValueRef o0, LLVMValueRef o1) { - return wrap(ConstantExpr::getSDiv(unwrap(o0), unwrap(o1), isExact != 0)); -} - LLVMValueRef LLVM_Hs_ConstLShr(unsigned isExact, LLVMValueRef o0, LLVMValueRef o1) { return wrap(ConstantExpr::getLShr(unwrap(o0), unwrap(o1), isExact != 0)); } @@ -92,12 +85,6 @@ unsigned LLVM_Hs_GetConstPredicate(LLVMValueRef v) { return unwrap(v)->getPredicate(); } -const unsigned *LLVM_Hs_GetConstIndices(LLVMValueRef v, unsigned *n) { - ArrayRef r = unwrap(v)->getIndices(); - *n = r.size(); - return r.data(); -} - const uint64_t *LLVM_Hs_GetConstantIntWords(LLVMValueRef v, unsigned *n) { const APInt &i = unwrap(v)->getValue(); *n = i.getNumWords(); @@ -127,5 +114,8 @@ LLVMValueRef LLVM_Hs_GetConstTokenNone(LLVMContextRef context) { return wrap(ConstantTokenNone::get(*unwrap(context))); } +LLVMTypeRef LLVM_Hs_GetConstGEPSourceType(LLVMValueRef v) { + return wrap(unwrap(v)->getSourceElementType()); +} } diff --git a/llvm-hs/src/LLVM/Internal/FFI/Context.hs b/llvm-hs/src/LLVM/Internal/FFI/Context.hs index 8fd08bb7..1af18d4f 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/Context.hs +++ b/llvm-hs/src/LLVM/Internal/FFI/Context.hs @@ -23,6 +23,9 @@ foreign import ccall unsafe "LLVMContextCreate" contextCreate :: foreign import ccall unsafe "LLVMGetGlobalContext" getGlobalContext :: IO (Ptr Context) +foreign import ccall unsafe "LLVM_Hs_SetOpaquePointers" contextSetOpaquePointers :: + Ptr Context -> IO () + -- | foreign import ccall unsafe "LLVMContextDispose" contextDispose :: Ptr Context -> IO () diff --git a/llvm-hs/src/LLVM/Internal/FFI/ContextC.cpp b/llvm-hs/src/LLVM/Internal/FFI/ContextC.cpp new file mode 100644 index 00000000..4b313c20 --- /dev/null +++ b/llvm-hs/src/LLVM/Internal/FFI/ContextC.cpp @@ -0,0 +1,13 @@ +#define __STDC_LIMIT_MACROS +#include "llvm-c/Core.h" +#include "llvm/IR/LLVMContext.h" + +using namespace llvm; + +extern "C" { + +void LLVM_Hs_SetOpaquePointers(LLVMContextRef context) { + unwrap(context)->setOpaquePointers(true); +} + +} diff --git a/llvm-hs/src/LLVM/Internal/FFI/Error.hs b/llvm-hs/src/LLVM/Internal/FFI/Error.hs new file mode 100644 index 00000000..ccc2c9e2 --- /dev/null +++ b/llvm-hs/src/LLVM/Internal/FFI/Error.hs @@ -0,0 +1,14 @@ +module LLVM.Internal.FFI.Error where + +import LLVM.Prelude + +import Foreign.Ptr +import Foreign.C.String + +data Error + +foreign import ccall unsafe "LLVMConsumeError" consumeError :: Ptr Error -> IO () + +foreign import ccall unsafe "LLVMGetErrorMessage" getErrorMessage :: Ptr Error -> IO CString + +foreign import ccall unsafe "LLVMDisposeErrorMessage" disposeErrorMessage :: CString -> IO () diff --git a/llvm-hs/src/LLVM/Internal/FFI/GlobalValue.h b/llvm-hs/src/LLVM/Internal/FFI/GlobalValue.h index 40f3450c..0fdb14dc 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/GlobalValue.h +++ b/llvm-hs/src/LLVM/Internal/FFI/GlobalValue.h @@ -23,7 +23,7 @@ macro(Any) \ macro(ExactMatch) \ macro(Largest) \ - macro(NoDuplicates) \ + macro(NoDeduplicate) \ macro(SameSize) typedef enum { diff --git a/llvm-hs/src/LLVM/Internal/FFI/GlobalValue.hs b/llvm-hs/src/LLVM/Internal/FFI/GlobalValue.hs index f745a463..c8f7013e 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/GlobalValue.hs +++ b/llvm-hs/src/LLVM/Internal/FFI/GlobalValue.hs @@ -13,12 +13,19 @@ import Foreign.C import LLVM.Internal.FFI.PtrHierarchy import LLVM.Internal.FFI.LLVMCTypes +import LLVM.Internal.FFI.Type data COMDAT foreign import ccall unsafe "LLVMIsAGlobalValue" isAGlobalValue :: Ptr Value -> IO (Ptr GlobalValue) +foreign import ccall unsafe "LLVM_Hs_GetGlobalValueType" getGlobalValueType :: + Ptr GlobalValue -> IO (Ptr Type) + +foreign import ccall unsafe "LLVM_Hs_GetGlobalValueAddressSpace" getGlobalValueAddressSpace :: + Ptr GlobalValue -> IO AddrSpace + foreign import ccall unsafe "LLVMGetLinkage" getLinkage :: Ptr GlobalValue -> IO Linkage diff --git a/llvm-hs/src/LLVM/Internal/FFI/GlobalValueC.cpp b/llvm-hs/src/LLVM/Internal/FFI/GlobalValueC.cpp index 1681463d..7474f251 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/GlobalValueC.cpp +++ b/llvm-hs/src/LLVM/Internal/FFI/GlobalValueC.cpp @@ -1,5 +1,6 @@ #define __STDC_LIMIT_MACROS #include "llvm/IR/Comdat.h" +#include "llvm/IR/Type.h" #include "llvm/IR/GlobalValue.h" #include "llvm/IR/GlobalObject.h" #include "llvm/IR/Metadata.h" @@ -78,4 +79,12 @@ void LLVM_Hs_GlobalObject_SetMetadata(GlobalObject* obj, unsigned kind, MDNode* obj->setMetadata(kind, node); } +LLVMTypeRef LLVM_Hs_GetGlobalValueType(LLVMValueRef v) { + return wrap(unwrap(v)->getValueType()); +} + +unsigned LLVM_Hs_GetGlobalValueAddressSpace(LLVMValueRef v) { + return unwrap(v)->getAddressSpace(); +} + } diff --git a/llvm-hs/src/LLVM/Internal/FFI/InlineAssembly.hs b/llvm-hs/src/LLVM/Internal/FFI/InlineAssembly.hs index f1797775..37c5e133 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/InlineAssembly.hs +++ b/llvm-hs/src/LLVM/Internal/FFI/InlineAssembly.hs @@ -33,3 +33,5 @@ foreign import ccall unsafe "LLVM_Hs_InlineAsmIsAlignStack" inlineAsmIsAlignStac foreign import ccall unsafe "LLVM_Hs_GetInlineAsmDialect" getInlineAsmDialect :: Ptr InlineAsm -> IO AsmDialect +foreign import ccall unsafe "LLVM_Hs_GetInlineAsmFunctionType" getInlineAsmFunctionType :: + Ptr InlineAsm -> IO (Ptr Type) diff --git a/llvm-hs/src/LLVM/Internal/FFI/InlineAssemblyC.cpp b/llvm-hs/src/LLVM/Internal/FFI/InlineAssemblyC.cpp index 92533904..cbabe76b 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/InlineAssemblyC.cpp +++ b/llvm-hs/src/LLVM/Internal/FFI/InlineAssemblyC.cpp @@ -39,7 +39,7 @@ LLVMValueRef LLVM_Hs_CreateInlineAsm( ) { return wrap( InlineAsm::get( - unwrap(t), + unwrap(t), asmStr, constraintsStr, hasSideEffects, @@ -69,5 +69,8 @@ LLVMAsmDialect LLVM_Hs_GetInlineAsmDialect(LLVMValueRef v) { return wrap(unwrap(v)->getDialect()); } +LLVMTypeRef LLVM_Hs_GetInlineAsmFunctionType(LLVMValueRef v) { + return wrap(unwrap(v)->getFunctionType()); } +} diff --git a/llvm-hs/src/LLVM/Internal/FFI/Instruction.hs b/llvm-hs/src/LLVM/Internal/FFI/Instruction.hs index 7719c4e4..14c2d2df 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/Instruction.hs +++ b/llvm-hs/src/LLVM/Internal/FFI/Instruction.hs @@ -49,6 +49,12 @@ foreign import ccall unsafe "LLVM_Hs_SetTailCallKind" setTailCallKind :: foreign import ccall unsafe "LLVMGetCalledValue" getCallSiteCalledValue :: Ptr Instruction -> IO (Ptr Value) +foreign import ccall unsafe "LLVMGetCalledFunctionType" getCalledFunctionType :: + Ptr Instruction -> IO (Ptr Type) + +foreign import ccall unsafe "LLVMGetGEPSourceElementType" getGEPSourceElementType :: + Ptr Instruction -> IO (Ptr Type) + foreign import ccall unsafe "LLVMGetNumArgOperands" getCallSiteNumArgOperands :: Ptr Instruction -> IO CUInt diff --git a/llvm-hs/src/LLVM/Internal/FFI/InstructionC.cpp b/llvm-hs/src/LLVM/Internal/FFI/InstructionC.cpp index d74fa32d..da1fd65a 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/InstructionC.cpp +++ b/llvm-hs/src/LLVM/Internal/FFI/InstructionC.cpp @@ -124,11 +124,13 @@ LLVMTypeRef LLVM_Hs_GetAllocatedType(LLVMValueRef a) { #define LLVM_HS_FOR_EACH_ALIGNMENT_INST(macro) \ macro(Alloca) \ macro(Load) \ - macro(Store) + macro(Store) \ + macro(AtomicCmpXchg) \ + macro(AtomicRMW) unsigned LLVM_Hs_GetInstrAlignment(LLVMValueRef l) { switch(unwrap(l)->getOpcode()) { -#define ENUM_CASE(n) case Instruction::n: return unwrap(l)->getAlignment(); +#define ENUM_CASE(n) case Instruction::n: return unwrap(l)->getAlign().value(); LLVM_HS_FOR_EACH_ALIGNMENT_INST(ENUM_CASE) #undef ENUM_CASE default: return 0; diff --git a/llvm-hs/src/LLVM/Internal/FFI/LLVMCTypes.hsc b/llvm-hs/src/LLVM/Internal/FFI/LLVMCTypes.hsc index 864c0f33..bb23fff6 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/LLVMCTypes.hsc +++ b/llvm-hs/src/LLVM/Internal/FFI/LLVMCTypes.hsc @@ -288,10 +288,10 @@ newtype TargetOptionFlag = TargetOptionFlag CUInt #define TOF_Rec(n) { #n, LLVM_Hs_TargetOptionFlag_ ## n }, #{inject TARGET_OPTION_FLAG, TargetOptionFlag, TargetOptionFlag, targetOptionFlag, TOF_Rec} -newtype MCTargetOptionFlag = MCTargetOptionFlag CUInt +newtype MCTargetOptionBoolFlag = MCTargetOptionBoolFlag CUInt deriving (Eq, Read, Show, Typeable, Data, Generic) -#define MCTOF_Rec(n) { #n, LLVM_Hs_MCTargetOptionFlag_ ## n }, -#{inject MC_TARGET_OPTION_FLAG, MCTargetOptionFlag, MCTargetOptionFlag, mcTargetOptionFlag, MCTOF_Rec} +#define MCTOF_Rec(n) { #n, LLVM_Hs_MCTargetOptionBoolFlag_ ## n }, +#{inject MC_TARGET_OPTION_BOOL_FLAG, MCTargetOptionBoolFlag, MCTargetOptionBoolFlag, mcTargetOptionFlag, MCTOF_Rec} newtype DebugCompressionType = DebugCompressionType CUInt deriving (Eq, Read, Show, Typeable, Data, Generic) diff --git a/llvm-hs/src/LLVM/Internal/FFI/Metadata.hs b/llvm-hs/src/LLVM/Internal/FFI/Metadata.hs index 969f3590..d9027575 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/Metadata.hs +++ b/llvm-hs/src/LLVM/Internal/FFI/Metadata.hs @@ -60,10 +60,8 @@ foreign import ccall unsafe "LLVM_Hs_Get_DILocation" getDILocation :: foreign import ccall unsafe "LLVM_Hs_GetMDValue" getMDValue :: Ptr MDValue -> IO (Ptr Value) -{- foreign import ccall unsafe "LLVM_Hs_DumpMetadata" dumpMetadata :: Ptr Metadata -> IO () --} foreign import ccall unsafe "LLVM_Hs_GetMetadataOperand" getMetadataOperand :: Ptr MetadataAsVal -> IO (Ptr Metadata) @@ -542,7 +540,7 @@ foreign import ccall unsafe "LLVM_Hs_DITemplateParameter_GetType" getDITemplateP -- DITemplateTypeParameter foreign import ccall unsafe "LLVM_Hs_Get_DITemplateTypeParameter" getDITemplateTypeParameter :: - Ptr Context -> Ptr MDString -> Ptr DIType -> IO (Ptr DITemplateTypeParameter) + Ptr Context -> Ptr MDString -> Ptr DIType -> Bool -> IO (Ptr DITemplateTypeParameter) -- DITemplateValueParameter diff --git a/llvm-hs/src/LLVM/Internal/FFI/MetadataC.cpp b/llvm-hs/src/LLVM/Internal/FFI/MetadataC.cpp index e9bdb095..93e8f16c 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/MetadataC.cpp +++ b/llvm-hs/src/LLVM/Internal/FFI/MetadataC.cpp @@ -3,6 +3,7 @@ #include #include "llvm/Support/FormattedStream.h" +#include "llvm/BinaryFormat/Dwarf.h" #include "llvm/Config/llvm-config.h" #include "llvm/IR/LLVMContext.h" #include "llvm/IR/Metadata.h" @@ -79,11 +80,9 @@ MDTuple* LLVM_Hs_Get_MDTuple(LLVMContextRef c, return MDTuple::get(*unwrap(c), {unwrap(mds), count}); } -/* void LLVM_Hs_DumpMetadata(LLVMMetadataRef md) { - unwrap(md)->dump(); + unwrap(md)->print(llvm::errs(), nullptr); } -*/ unsigned LLVM_Hs_GetMDKindNames( LLVMContextRef c, @@ -226,7 +225,7 @@ MDString* LLVM_Hs_DIFileGetDirectory(DIFile *di) { MDString* LLVM_Hs_DIFileGetChecksum(DIFile *di) { auto checksumInfo = di->getRawChecksum(); - if (checksumInfo.hasValue()) { + if (checksumInfo.has_value()) { return checksumInfo->Value; } return nullptr; @@ -234,7 +233,7 @@ MDString* LLVM_Hs_DIFileGetChecksum(DIFile *di) { llvm::DIFile::ChecksumKind LLVM_Hs_DIFileGetChecksumKind(DIFile *di) { auto checksumInfo = di->getRawChecksum(); - if (checksumInfo.hasValue()) { + if (checksumInfo.has_value()) { return checksumInfo->Kind; } return static_cast(0); @@ -471,8 +470,8 @@ DILexicalBlock* LLVM_Hs_Get_DILexicalBlock(LLVMContextRef ctx, DILocalScope* sco LLVMBool LLVM_Hs_DIDerivedTypeGetAddressSpace(DIDerivedType *a, unsigned *x) { auto addressSpace = a->getDWARFAddressSpace(); - if (addressSpace.hasValue()) { - *x = addressSpace.getValue(); + if (addressSpace.has_value()) { + *x = addressSpace.value(); return 1; } else { return 0; @@ -636,7 +635,7 @@ DILocalVariable* LLVM_Hs_Get_DILocalVariable(LLVMContextRef ctx, DINode::DIFlags flags, uint32_t alignInBits) { LLVMContext &c = *unwrap(ctx); return DILocalVariable::get(c, static_cast(scope), name, file, line, type, - arg, flags, alignInBits); + arg, flags, alignInBits, nullptr); } uint16_t LLVM_Hs_DILocalVariable_GetArg(DILocalVariable* v) { @@ -661,7 +660,7 @@ DIGlobalVariable* LLVM_Hs_Get_DIGlobalVariable(LLVMContextRef ctx, file, line, type, isLocalToUnit, isDefinition, declaration, templateParams, - alignInBits); + alignInBits, nullptr); } LLVMBool LLVM_Hs_DIGlobalVariable_GetLocal(DIGlobalVariable* v) { diff --git a/llvm-hs/src/LLVM/Internal/FFI/Module.hs b/llvm-hs/src/LLVM/Internal/FFI/Module.hs index d52de457..9c72f1c9 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/Module.hs +++ b/llvm-hs/src/LLVM/Internal/FFI/Module.hs @@ -37,6 +37,9 @@ foreign import ccall unsafe "LLVMGetTarget" getTargetTriple :: foreign import ccall unsafe "LLVMSetTarget" setTargetTriple :: Ptr Module -> CString -> IO () +foreign import ccall unsafe "LLVM_Hs_DumpModule" dumpModule :: + Ptr Module -> IO () + foreign import ccall unsafe "LLVM_Hs_GetModuleIdentifier" getModuleIdentifier :: Ptr Module -> IO (OwnerTransfered CString) diff --git a/llvm-hs/src/LLVM/Internal/FFI/ModuleC.cpp b/llvm-hs/src/LLVM/Internal/FFI/ModuleC.cpp index f9af19a3..80751576 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/ModuleC.cpp +++ b/llvm-hs/src/LLVM/Internal/FFI/ModuleC.cpp @@ -6,6 +6,10 @@ using namespace llvm; extern "C" { +void LLVM_Hs_DumpModule(LLVMModuleRef m) { + unwrap(m)->print(llvm::errs(), nullptr); +} + char *LLVM_Hs_GetModuleIdentifier(LLVMModuleRef val) { return strdup(unwrap(val)->getModuleIdentifier().c_str()); } diff --git a/llvm-hs/src/LLVM/Internal/FFI/OrcJITC.cpp b/llvm-hs/src/LLVM/Internal/FFI/OrcJITC.cpp index e43cc1e8..5f04d33e 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/OrcJITC.cpp +++ b/llvm-hs/src/LLVM/Internal/FFI/OrcJITC.cpp @@ -8,7 +8,6 @@ #include #include #include -#include #include #include #include @@ -53,7 +52,14 @@ extern "C" { // ExecutionSession ExecutionSession *LLVM_Hs_createExecutionSession() { - return new ExecutionSession(); + auto sepc = SelfExecutorProcessControl::Create(); + if (sepc) { + return new ExecutionSession(std::move(*sepc)); + } else { + llvm::errs() << sepc.takeError() << "\n"; + // FIXME: Better error handling + exit(1); + } } void LLVM_Hs_disposeExecutionSession(ExecutionSession *es) { @@ -111,7 +117,7 @@ ObjectLayer* LLVM_Hs_createRTDyldObjectLinkingLayer(ExecutionSession* es) { } ObjectLayer* LLVM_Hs_createObjectLinkingLayer(ExecutionSession* es) { - return new ObjectLinkingLayer(*es, std::make_unique()); + return new ObjectLinkingLayer(*es); } void LLVM_Hs_ObjectLayerAddObjectFile(ObjectLayer* ol, JITDylib* dylib, const char* path) { diff --git a/llvm-hs/src/LLVM/Internal/FFI/PassManager.hs b/llvm-hs/src/LLVM/Internal/FFI/PassManager.hs deleted file mode 100644 index 330345f5..00000000 --- a/llvm-hs/src/LLVM/Internal/FFI/PassManager.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE - TemplateHaskell, - ForeignFunctionInterface, - CPP - #-} - -module LLVM.Internal.FFI.PassManager where - -import LLVM.Prelude - -import qualified Language.Haskell.TH as TH - -import Foreign.Ptr -import Foreign.C - -import LLVM.Internal.FFI.LLVMCTypes -import LLVM.Internal.FFI.PtrHierarchy -import LLVM.Internal.FFI.Cleanup -import LLVM.Internal.FFI.Module -import LLVM.Internal.FFI.Target -import LLVM.Internal.FFI.Transforms - -import qualified LLVM.Transforms as G - -data PassManager - -foreign import ccall unsafe "LLVMCreatePassManager" createPassManager :: - IO (Ptr PassManager) - -foreign import ccall unsafe "LLVMDisposePassManager" disposePassManager :: - Ptr PassManager -> IO () - -foreign import ccall unsafe "LLVMRunPassManager" runPassManager :: - Ptr PassManager -> Ptr Module -> IO CUInt - -foreign import ccall unsafe "LLVMCreateFunctionPassManagerForModule" createFunctionPassManagerForModule :: - Ptr Module -> IO (Ptr PassManager) - -foreign import ccall unsafe "LLVMInitializeFunctionPassManager" initializeFunctionPassManager :: - Ptr PassManager -> IO CUInt - -foreign import ccall unsafe "LLVMRunFunctionPassManager" runFunctionPassManager :: - Ptr PassManager -> Ptr Value -> IO CUInt - -foreign import ccall unsafe "LLVMFinalizeFunctionPassManager" finalizeFunctionPassManager :: - Ptr PassManager -> IO CUInt - -foreign import ccall unsafe "LLVMAddAnalysisPasses" addAnalysisPasses :: - Ptr TargetMachine -> Ptr PassManager -> IO () - -foreign import ccall unsafe "LLVMAddTargetLibraryInfo" addTargetLibraryInfoPass' :: - Ptr TargetLibraryInfo -> Ptr PassManager -> IO () - -addTargetLibraryInfoPass :: Ptr PassManager -> Ptr TargetLibraryInfo -> IO () -addTargetLibraryInfoPass = flip addTargetLibraryInfoPass' - -$(do - let declareForeign :: TH.Name -> [TH.Type] -> TH.DecsQ - declareForeign hName extraParams = do - let n = TH.nameBase hName - passTypeMapping :: TH.Type -> TH.TypeQ - passTypeMapping t = case t of - TH.ConT h | h == ''Word -> [t| CUInt |] - | h == ''G.GCOVVersion -> [t| CString |] - -- some of the LLVM methods for making passes use "-1" as a special value - -- handle those here - TH.AppT (TH.ConT mby) t' | mby == ''Maybe -> - case t' of - TH.ConT h | h == ''Bool -> [t| NothingAsMinusOne Bool |] - | h == ''Word -> [t| NothingAsMinusOne Word |] - | h == ''FilePath -> [t| NothingAsEmptyString CString |] - _ -> typeMapping t - _ -> typeMapping t - foreignDecl - (cName n) - ("add" ++ n ++ "Pass") - ([[t| Ptr PassManager |]] - ++ [[t| Ptr TargetMachine |] | needsTargetMachine n] - ++ map passTypeMapping extraParams) - (TH.tupleT 0) -#if __GLASGOW_HASKELL__ < 800 - TH.TyConI (TH.DataD _ _ _ cons _) <- TH.reify ''G.Pass -#else - TH.TyConI (TH.DataD _ _ _ _ cons _) <- TH.reify ''G.Pass -#endif - liftM concat $ forM cons $ \con -> case con of - TH.RecC n l -> declareForeign n [ t | (_,_,t) <- l ] - TH.NormalC n [] -> declareForeign n [] - _ -> error "pass descriptor constructors with fields need to be records" - ) - -data PassManagerBuilder - -foreign import ccall unsafe "LLVMPassManagerBuilderCreate" passManagerBuilderCreate :: - IO (Ptr PassManagerBuilder) - -foreign import ccall unsafe "LLVMPassManagerBuilderDispose" passManagerBuilderDispose :: - Ptr PassManagerBuilder -> IO () - -foreign import ccall unsafe "LLVMPassManagerBuilderSetOptLevel" passManagerBuilderSetOptLevel :: - Ptr PassManagerBuilder -> CUInt -> IO () - -foreign import ccall unsafe "LLVMPassManagerBuilderSetSizeLevel" passManagerBuilderSetSizeLevel :: - Ptr PassManagerBuilder -> CUInt -> IO () - -foreign import ccall unsafe "LLVMPassManagerBuilderSetDisableUnitAtATime" passManagerBuilderSetDisableUnitAtATime :: - Ptr PassManagerBuilder -> LLVMBool -> IO () - -foreign import ccall unsafe "LLVMPassManagerBuilderSetDisableUnrollLoops" passManagerBuilderSetDisableUnrollLoops :: - Ptr PassManagerBuilder -> CUInt -> IO () - -foreign import ccall unsafe "LLVMPassManagerBuilderSetDisableSimplifyLibCalls" passManagerBuilderSetDisableSimplifyLibCalls :: - Ptr PassManagerBuilder -> LLVMBool -> IO () - -foreign import ccall unsafe "LLVMPassManagerBuilderUseInlinerWithThreshold" passManagerBuilderUseInlinerWithThreshold :: - Ptr PassManagerBuilder -> CUInt -> IO () - -foreign import ccall unsafe "LLVMPassManagerBuilderPopulateFunctionPassManager" passManagerBuilderPopulateFunctionPassManager :: - Ptr PassManagerBuilder -> Ptr PassManager -> IO () - -foreign import ccall unsafe "LLVMPassManagerBuilderPopulateModulePassManager" passManagerBuilderPopulateModulePassManager :: - Ptr PassManagerBuilder -> Ptr PassManager -> IO () - -foreign import ccall unsafe "LLVMPassManagerBuilderPopulateLTOPassManager" passManagerBuilderPopulateLTOPassManager :: - Ptr PassManagerBuilder -> Ptr PassManager -> CUChar -> CUChar -> IO () - -foreign import ccall unsafe "LLVM_Hs_PassManagerBuilderSetLibraryInfo" passManagerBuilderSetLibraryInfo :: - Ptr PassManagerBuilder -> Ptr TargetLibraryInfo -> IO () - -foreign import ccall unsafe "LLVM_Hs_PassManagerBuilderSetLoopVectorize" passManagerBuilderSetLoopVectorize :: - Ptr PassManagerBuilder -> LLVMBool -> IO () - -foreign import ccall unsafe "LLVM_Hs_PassManagerBuilderSetSuperwordLevelParallelismVectorize" passManagerBuilderSetSuperwordLevelParallelismVectorize :: - Ptr PassManagerBuilder -> LLVMBool -> IO () diff --git a/llvm-hs/src/LLVM/Internal/FFI/PassManagerC.cpp b/llvm-hs/src/LLVM/Internal/FFI/PassManagerC.cpp deleted file mode 100644 index 827b6302..00000000 --- a/llvm-hs/src/LLVM/Internal/FFI/PassManagerC.cpp +++ /dev/null @@ -1,206 +0,0 @@ -#define __STDC_LIMIT_MACROS -#include "llvm/IR/LLVMContext.h" -#include "llvm/IR/DataLayout.h" -#include "llvm/IR/LegacyPassManager.h" -#include "llvm/Transforms/Scalar.h" -#include "llvm/Transforms/Scalar/GVN.h" -#include "llvm/Transforms/IPO.h" -#include "llvm/Transforms/IPO/Internalize.h" -#include "llvm/Transforms/IPO/PassManagerBuilder.h" -#include "llvm/Transforms/Vectorize.h" -#include "llvm/Transforms/Instrumentation.h" -#include "llvm/Transforms/Instrumentation/AddressSanitizer.h" -#include "llvm/Transforms/Instrumentation/BoundsChecking.h" -#include "llvm/Transforms/Instrumentation/MemorySanitizer.h" -#include "llvm/Transforms/Instrumentation/ThreadSanitizer.h" -#include "llvm/Transforms/Utils.h" -#include "llvm/LinkAllPasses.h" -#include "llvm/CodeGen/Passes.h" -#include "llvm/CodeGen/TargetLowering.h" -#include "llvm-c/Target.h" -#include "llvm-c/Transforms/PassManagerBuilder.h" -#include "llvm/Analysis/TargetLibraryInfo.h" -#include "llvm/Target/TargetMachine.h" - -#include "llvm-c/Core.h" - -using namespace llvm; - -extern "C" { -typedef struct LLVMOpaqueVectorizationConfig *LLVMVectorizationConfigRef; -typedef struct LLVMOpaqueTargetLowering *LLVMTargetLoweringRef; -typedef struct LLVMOpaqueTargetMachine *LLVMTargetMachineRef; -} - -namespace llvm { -inline TargetLowering *unwrap(LLVMTargetLoweringRef P) { - return reinterpret_cast(P); -} - -inline LLVMTargetLoweringRef wrap(const TargetLowering *P) { - return reinterpret_cast(const_cast(P)); -} - -inline TargetMachine *unwrap(LLVMTargetMachineRef P) { - return reinterpret_cast(P); -} - -inline LLVMTargetMachineRef wrap(const TargetMachine *P) { - return reinterpret_cast(const_cast(P)); -} - -inline TargetLibraryInfoImpl *unwrap(LLVMTargetLibraryInfoRef P) { - return reinterpret_cast(P); -} - -} - -extern "C" { - -#define LLVM_HS_FOR_EACH_PASS_WITHOUT_LLVM_C_BINDING(macro) \ - macro(BreakCriticalEdges) \ - macro(DeadCodeElimination) \ - macro(DemoteRegisterToMemory) \ - macro(LCSSA) \ - macro(LoopInstSimplify) \ - macro(LowerAtomic) \ - macro(LowerSwitch) \ - macro(MergeFunctions) \ - macro(PartialInlining) \ - macro(Sinking) \ - macro(StripDeadDebugInfo) \ - macro(StripDebugDeclare) \ - macro(StripNonDebugSymbols) \ - -#define ENUM_CASE(p) \ -void LLVM_Hs_Add ## p ## Pass(LLVMPassManagerRef PM) { \ - unwrap(PM)->add(create ## p ## Pass()); \ -} -LLVM_HS_FOR_EACH_PASS_WITHOUT_LLVM_C_BINDING(ENUM_CASE) -#undef ENUM_CASE - -void LLVM_Hs_AddCodeGenPreparePass(LLVMPassManagerRef PM) { - unwrap(PM)->add(createCodeGenPreparePass()); -} - -void LLVM_Hs_AddGlobalValueNumberingPass(LLVMPassManagerRef PM, LLVMBool noLoads) { - unwrap(PM)->add(createGVNPass(noLoads)); -} - -void LLVM_Hs_AddInternalizePass(LLVMPassManagerRef PM, unsigned nExports, const char **exports) { - std::vector exportList(nExports); - for (unsigned i = 0; i < nExports; ++i) { - exportList.at(i) = exports[i]; - } - std::function mustPreserveGV = [exportList](const GlobalValue & gv) { - for (const auto& exp : exportList) { - if (gv.getName().equals(exp)) { - return true; - } - } - return false; - }; - unwrap(PM)->add(createInternalizePass(std::move(mustPreserveGV))); -} - -void LLVM_Hs_AddLoopStrengthReducePass(LLVMPassManagerRef PM) { - unwrap(PM)->add(createLoopStrengthReducePass()); -} - -void LLVM_Hs_AddLowerInvokePass(LLVMPassManagerRef PM) { - unwrap(PM)->add(createLowerInvokePass()); -} - -void LLVM_Hs_AddSROAPass(LLVMPassManagerRef PM) { - unwrap(PM)->add(createSROAPass()); -} - -void LLVM_Hs_AddGCOVProfilerPass( - LLVMPassManagerRef PM, - LLVMBool emitNotes, - LLVMBool emitData, - const char *version, - LLVMBool noRedZone, - LLVMBool atomic, - const char *filter, - const char *exclude -) { - auto options = GCOVOptions::getDefault(); - options.EmitNotes = emitNotes; - options.EmitData = emitData; - std::copy(version, version+4, options.Version); - options.NoRedZone = noRedZone; - options.Atomic = atomic; - options.Filter = filter; - options.Exclude = exclude; - unwrap(PM)->add(createGCOVProfilerPass(options)); -} - -void LLVM_Hs_AddAddressSanitizerFunctionPass( - LLVMPassManagerRef PM -) { - unwrap(PM)->add(createAddressSanitizerFunctionPass()); -} - -void LLVM_Hs_AddAddressSanitizerModulePass( - LLVMPassManagerRef PM -) { - unwrap(PM)->add(createModuleAddressSanitizerLegacyPassPass()); -} - -void LLVM_Hs_AddMemorySanitizerPass( - LLVMPassManagerRef PM, - LLVMBool trackOrigins, - LLVMBool recover, - LLVMBool kernel -) { - unwrap(PM)->add(createMemorySanitizerLegacyPassPass( - {trackOrigins, static_cast(recover), static_cast(kernel)})); -} - -void LLVM_Hs_AddThreadSanitizerPass( - LLVMPassManagerRef PM -) { - unwrap(PM)->add(createThreadSanitizerLegacyPassPass()); -} - -void LLVM_Hs_AddBoundsCheckingPass(LLVMPassManagerRef PM) { - unwrap(PM)->add(createBoundsCheckingLegacyPass()); -} - -void LLVM_Hs_AddIPSCCPPass(LLVMPassManagerRef PM) { - unwrap(PM)->add(createIPSCCPPass()); -} - -void LLVM_Hs_AddLoopVectorizePass( - LLVMPassManagerRef PM, - LLVMBool interleaveOnlyWhenForced, - LLVMBool vectorizeOnlyWhenForced -) { - unwrap(PM)->add(createLoopVectorizePass(interleaveOnlyWhenForced, vectorizeOnlyWhenForced)); -} - -void LLVM_Hs_PassManagerBuilderSetLibraryInfo( - LLVMPassManagerBuilderRef PMB, - LLVMTargetLibraryInfoRef l -) { - // The PassManager frees the TargetLibraryInfo when done, - // but we also free our ref, so give it a new copy. - unwrap(PMB)->LibraryInfo = new TargetLibraryInfoImpl(*unwrap(l)); -} - -void LLVM_Hs_PassManagerBuilderSetLoopVectorize( - LLVMPassManagerBuilderRef PMB, - LLVMBool runLoopVectorization -) { - unwrap(PMB)->LoopVectorize = runLoopVectorization; -} - -void LLVM_Hs_PassManagerBuilderSetSuperwordLevelParallelismVectorize( - LLVMPassManagerBuilderRef PMB, - LLVMBool runSLPVectorization -) { - unwrap(PMB)->SLPVectorize = runSLPVectorization; -} - -} diff --git a/llvm-hs/src/LLVM/Internal/FFI/Passes.hs b/llvm-hs/src/LLVM/Internal/FFI/Passes.hs new file mode 100644 index 00000000..6179610a --- /dev/null +++ b/llvm-hs/src/LLVM/Internal/FFI/Passes.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module LLVM.Internal.FFI.Passes where + +import LLVM.Prelude + +import Foreign.Ptr +import Foreign.C.Types +import Foreign.C.String + +import LLVM.Internal.FFI.Error +import LLVM.Internal.FFI.Module +import LLVM.Internal.FFI.Target + + +data PassBuilderOptions + +foreign import ccall unsafe "LLVMCreatePassBuilderOptions" createPassBuilderOptions :: IO (Ptr PassBuilderOptions) +foreign import ccall unsafe "LLVMDisposePassBuilderOptions" disposePassBuilderOptions :: Ptr PassBuilderOptions -> IO () + +foreign import ccall unsafe "LLVMRunPasses" runPasses + :: Ptr Module -> CString -> Ptr TargetMachine -> Ptr PassBuilderOptions -> IO (Ptr Error) + +data PassBuilderPackage +data ModulePassManager +data ModulePass + +foreign import ccall unsafe "LLVM_Hs_CreatePassBuilderPackage" createPassBuilderPackage + :: Ptr TargetMachine -> IO (Ptr PassBuilderPackage) + +foreign import ccall unsafe "LLVM_Hs_DisposePassBuilderPackage" disposePassBuilderPackage + :: Ptr PassBuilderPackage -> IO () + +foreign import ccall unsafe "LLVM_Hs_CreateModulePassManager" createModulePassManager + :: IO (Ptr ModulePassManager) + +foreign import ccall unsafe "LLVM_Hs_DisposeModulePassManager" disposeModulePassManager + :: Ptr ModulePassManager -> IO () + +foreign import ccall unsafe "LLVM_Hs_ModulePassManagerRun" modulePassManagerRun + :: Ptr ModulePassManager -> Ptr PassBuilderPackage -> Ptr Module -> IO () + +foreign import ccall unsafe "LLVM_Hs_AddPerModuleDefaultPipeline" addPerModuleDefaultPipeline + :: Ptr ModulePassManager -> Ptr PassBuilderPackage -> CInt -> IO () + +foreign import ccall unsafe "LLVM_Hs_AddGlobalDeadCodeEliminationPass" addGlobalDeadCodeEliminationPass + :: Ptr ModulePassManager -> IO () + +foreign import ccall unsafe "LLVM_Hs_AddAlwaysInlinePass" addAlwaysInlinePass + :: Ptr ModulePassManager -> CInt -> IO () + +foreign import ccall unsafe "LLVM_Hs_AddInternalizeFunctionsPass" addInternalizeFunctionsPass + :: Ptr ModulePassManager -> CInt -> Ptr CString -> IO () diff --git a/llvm-hs/src/LLVM/Internal/FFI/PassesC.cpp b/llvm-hs/src/LLVM/Internal/FFI/PassesC.cpp new file mode 100644 index 00000000..1477e807 --- /dev/null +++ b/llvm-hs/src/LLVM/Internal/FFI/PassesC.cpp @@ -0,0 +1,86 @@ +#define __STDC_LIMIT_MACROS +#include "llvm/Passes/PassBuilder.h" +#include "llvm/Transforms/IPO/GlobalDCE.h" +#include "llvm/Transforms/IPO/AlwaysInliner.h" +#include "llvm/Transforms/IPO/Internalize.h" + +using namespace llvm; + +namespace { + +struct PassBuilderPackage { + LoopAnalysisManager LAM; + FunctionAnalysisManager FAM; + CGSCCAnalysisManager CGAM; + ModuleAnalysisManager MAM; + PassBuilder PB; + + PassBuilderPackage(TargetMachine* tm) : PB(tm) { + PB.registerModuleAnalyses(MAM); + PB.registerCGSCCAnalyses(CGAM); + PB.registerFunctionAnalyses(FAM); + PB.registerLoopAnalyses(LAM); + PB.crossRegisterProxies(LAM, FAM, CGAM, MAM); + } +}; + +} + +extern "C" { + +PassBuilderPackage* LLVM_Hs_CreatePassBuilderPackage(TargetMachine* tm) { + return new PassBuilderPackage(tm); +} + +void LLVM_Hs_DisposePassBuilderPackage(PassBuilderPackage* pbp) { + delete pbp; +} + +ModulePassManager* LLVM_Hs_CreateModulePassManager() { + return new ModulePassManager(); +} + +void LLVM_Hs_DisposeModulePassManager(ModulePassManager* mpm) { + delete mpm; +} + +void LLVM_Hs_ModulePassManagerRun(ModulePassManager *mpm, PassBuilderPackage* pbp, Module* m) { + mpm->run(*m, pbp->MAM); +} + +void LLVM_Hs_AddPerModuleDefaultPipeline(ModulePassManager* mpm, PassBuilderPackage* pbp, int opt) { + OptimizationLevel opt_lvl; + if (opt == 0) { + opt_lvl = OptimizationLevel::O0; + } if (opt == 1) { + opt_lvl = OptimizationLevel::O1; + } else if (opt == 2) { + opt_lvl = OptimizationLevel::O2; + } else if (opt >= 3) { + opt_lvl = OptimizationLevel::O3; + } + mpm->addPass(pbp->PB.buildPerModuleDefaultPipeline(opt_lvl)); +} + +void LLVM_Hs_AddGlobalDeadCodeEliminationPass(ModulePassManager* mpm) { + mpm->addPass(GlobalDCEPass()); +} + +void LLVM_Hs_AddAlwaysInlinePass(ModulePassManager* mpm, int insert_lifetimes) { + mpm->addPass(AlwaysInlinerPass(insert_lifetimes)); +} + +void LLVM_Hs_AddInternalizeFunctionsPass(ModulePassManager* mpm, int num_exports, char** exports) { + std::vector owned_exports; + owned_exports.reserve(num_exports); + for (int i = 0; i < num_exports; ++i) { + owned_exports.push_back(std::string(exports[i])); + } + StringSet<> exports_set; + for (const std::string& e : owned_exports) exports_set.insert(e); + mpm->addPass(InternalizePass([owned_exports, exports_set](const GlobalValue &gv) -> bool { + return exports_set.contains(gv.getName()); + })); +} + +} diff --git a/llvm-hs/src/LLVM/Internal/FFI/Target.h b/llvm-hs/src/LLVM/Internal/FFI/Target.h index 8da5b0a4..454e1a3c 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/Target.h +++ b/llvm-hs/src/LLVM/Internal/FFI/Target.h @@ -68,30 +68,28 @@ typedef enum { #undef ENUM_CASE } LLVM_Hs_TargetOptionFlag; -#define LLVM_HS_FOR_EACH_MC_TARGET_OPTION_FLAG(macro) \ - macro(MCRelaxAll) \ - macro(MCNoExecStack) \ - macro(MCFatalWarnings) \ - macro(MCNoWarn) \ - macro(MCNoDeprecatedWarn) \ - macro(MCSaveTempLabels) \ - macro(MCUseDwarfDirectory) \ - macro(MCIncrementalLinkerCompatible) \ - macro(ShowMCEncoding) \ - macro(ShowMCInst) \ - macro(AsmVerbose) \ +#define LLVM_HS_FOR_EACH_MC_TARGET_OPTION_BOOL_FLAG(macro) \ + macro(MCRelaxAll) \ + macro(MCNoExecStack) \ + macro(MCFatalWarnings) \ + macro(MCNoWarn) \ + macro(MCNoDeprecatedWarn) \ + macro(MCSaveTempLabels) \ + macro(MCIncrementalLinkerCompatible) \ + macro(ShowMCEncoding) \ + macro(ShowMCInst) \ + macro(AsmVerbose) \ macro(PreserveAsmComments) typedef enum { -#define ENUM_CASE(n) LLVM_Hs_MCTargetOptionFlag_ ## n, - LLVM_HS_FOR_EACH_MC_TARGET_OPTION_FLAG(ENUM_CASE) +#define ENUM_CASE(n) LLVM_Hs_MCTargetOptionBoolFlag_ ## n, + LLVM_HS_FOR_EACH_MC_TARGET_OPTION_BOOL_FLAG(ENUM_CASE) #undef ENUM_CASE -} LLVM_Hs_MCTargetOptionFlag; +} LLVM_Hs_MCTargetOptionBoolFlag; #define LLVM_HS_FOR_EACH_DEBUG_COMPRESSION_TYPE(macro) \ macro(None) \ - macro(GNU) \ - macro(Z) + macro(Zlib) typedef enum { #define ENUM_CASE(n) LLVM_Hs_DebugCompressionType_ ## n, diff --git a/llvm-hs/src/LLVM/Internal/FFI/Target.hs b/llvm-hs/src/LLVM/Internal/FFI/Target.hs index 901d979a..fb2fc325 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/Target.hs +++ b/llvm-hs/src/LLVM/Internal/FFI/Target.hs @@ -35,11 +35,17 @@ foreign import ccall unsafe "LLVM_Hs_SetTargetOptionFlag" setTargetOptionFlag :: foreign import ccall unsafe "LLVM_Hs_GetTargetOptionFlag" getTargetOptionsFlag :: Ptr TargetOptions -> TargetOptionFlag -> IO LLVMBool -foreign import ccall unsafe "LLVM_Hs_SetMCTargetOptionFlag" setMCTargetOptionFlag :: - Ptr MCTargetOptions -> MCTargetOptionFlag -> LLVMBool -> IO () +foreign import ccall unsafe "LLVM_Hs_SetMCTargetOptionBoolFlag" setMCTargetOptionBoolFlag :: + Ptr MCTargetOptions -> MCTargetOptionBoolFlag -> LLVMBool -> IO () -foreign import ccall unsafe "LLVM_Hs_GetMCTargetOptionFlag" getMCTargetOptionsFlag :: - Ptr MCTargetOptions -> MCTargetOptionFlag -> IO LLVMBool +foreign import ccall unsafe "LLVM_Hs_GetMCTargetOptionBoolFlag" getMCTargetOptionsBoolFlag :: + Ptr MCTargetOptions -> MCTargetOptionBoolFlag -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_SetMCTargetOptionFlagUseDwarfDirectory" setMCTargetOptionFlagUseDwarfDirectory :: + Ptr MCTargetOptions -> CInt -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetMCTargetOptionFlagUseDwarfDirectory" getMCTargetOptionFlagUseDwarfDirectory :: + Ptr MCTargetOptions -> IO CInt foreign import ccall unsafe "LLVM_Hs_GetCompressDebugSections" getCompressDebugSections :: Ptr TargetOptions -> IO DebugCompressionType @@ -47,12 +53,6 @@ foreign import ccall unsafe "LLVM_Hs_GetCompressDebugSections" getCompressDebugS foreign import ccall unsafe "LLVM_Hs_SetCompressDebugSections" setCompressDebugSections :: Ptr TargetOptions -> DebugCompressionType -> IO () -foreign import ccall unsafe "LLVM_Hs_SetStackAlignmentOverride" setStackAlignmentOverride :: - Ptr TargetOptions -> CUInt -> IO () - -foreign import ccall unsafe "LLVM_Hs_GetStackAlignmentOverride" getStackAlignmentOverride :: - Ptr TargetOptions -> IO CUInt - foreign import ccall unsafe "LLVM_Hs_SetFloatABIType" setFloatABIType :: Ptr TargetOptions -> FloatABIType -> IO () diff --git a/llvm-hs/src/LLVM/Internal/FFI/TargetC.cpp b/llvm-hs/src/LLVM/Internal/FFI/TargetC.cpp index fe1f7224..c6746fcf 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/TargetC.cpp +++ b/llvm-hs/src/LLVM/Internal/FFI/TargetC.cpp @@ -12,9 +12,9 @@ #include "llvm/IR/DataLayout.h" #include "llvm/IR/LegacyPassManager.h" #include "llvm/IR/Module.h" +#include "llvm/MC/TargetRegistry.h" #include "llvm/Support/FormattedStream.h" #include "llvm/Support/Host.h" -#include "llvm/Support/TargetRegistry.h" #include "llvm/Support/TargetSelect.h" #include "llvm/Target/CodeGenCWrappers.h" #include "llvm/Target/TargetMachine.h" @@ -270,18 +270,29 @@ void LLVM_Hs_SetTargetOptionFlag(TargetOptions *to, LLVM_Hs_TargetOptionFlag f, } } -void LLVM_Hs_SetMCTargetOptionFlag(MCTargetOptions *to, - LLVM_Hs_MCTargetOptionFlag f, unsigned v) { +void LLVM_Hs_SetMCTargetOptionBoolFlag(MCTargetOptions *to, + LLVM_Hs_MCTargetOptionBoolFlag f, + unsigned v) { switch (f) { #define ENUM_CASE(op) \ - case LLVM_Hs_MCTargetOptionFlag_##op: \ + case LLVM_Hs_MCTargetOptionBoolFlag_##op: \ to->op = v ? 1 : 0; \ break; - LLVM_HS_FOR_EACH_MC_TARGET_OPTION_FLAG(ENUM_CASE) + LLVM_HS_FOR_EACH_MC_TARGET_OPTION_BOOL_FLAG(ENUM_CASE) #undef ENUM_CASE } } +void LLVM_Hs_SetMCTargetOptionFlagUseDwarfDirectory(MCTargetOptions *to, int v) { + if (v == 0) { + to->MCUseDwarfDirectory = MCTargetOptions::DisableDwarfDirectory; + } else if (v == 1) { + to->MCUseDwarfDirectory = MCTargetOptions::EnableDwarfDirectory; + } else { + to->MCUseDwarfDirectory = MCTargetOptions::DefaultDwarfDirectory; + } +} + static llvm::DebugCompressionType unwrap(LLVM_Hs_DebugCompressionType compressionType) { switch (compressionType) { @@ -335,13 +346,13 @@ unsigned LLVM_Hs_GetTargetOptionFlag(TargetOptions *to, } } -unsigned LLVM_Hs_GetMCTargetOptionFlag(MCTargetOptions *to, - LLVM_Hs_MCTargetOptionFlag f) { +unsigned LLVM_Hs_GetMCTargetOptionBoolFlag(MCTargetOptions *to, + LLVM_Hs_MCTargetOptionBoolFlag f) { switch (f) { #define ENUM_CASE(op) \ - case LLVM_Hs_MCTargetOptionFlag_##op: \ + case LLVM_Hs_MCTargetOptionBoolFlag_##op: \ return to->op; - LLVM_HS_FOR_EACH_MC_TARGET_OPTION_FLAG(ENUM_CASE) + LLVM_HS_FOR_EACH_MC_TARGET_OPTION_BOOL_FLAG(ENUM_CASE) #undef ENUM_CASE default: reportFatalError("Unknown machine code target option flag"); @@ -349,12 +360,8 @@ unsigned LLVM_Hs_GetMCTargetOptionFlag(MCTargetOptions *to, } } -void LLVM_Hs_SetStackAlignmentOverride(TargetOptions *to, unsigned v) { - to->StackAlignmentOverride = v; -} - -unsigned LLVM_Hs_GetStackAlignmentOverride(TargetOptions *to) { - return to->StackAlignmentOverride; +int LLVM_Hs_GetMCTargetOptionFlagUseDwarfDirectory(MCTargetOptions *to) { + return to->MCUseDwarfDirectory; } void LLVM_Hs_SetFloatABIType(TargetOptions *to, LLVM_Hs_FloatABI v) { diff --git a/llvm-hs/src/LLVM/Internal/FFI/Transforms.hs b/llvm-hs/src/LLVM/Internal/FFI/Transforms.hs deleted file mode 100644 index b649eb2f..00000000 --- a/llvm-hs/src/LLVM/Internal/FFI/Transforms.hs +++ /dev/null @@ -1,75 +0,0 @@ --- | Code used with Template Haskell to build the FFI for transform passes. -module LLVM.Internal.FFI.Transforms where - -import LLVM.Prelude - --- | does the constructor for this pass require a TargetMachine object -needsTargetMachine :: String -> Bool -needsTargetMachine "CodeGenPrepare" = True -needsTargetMachine _ = False - --- | Translate a Haskell name (used in the public Haskell interface, typically not abbreviated) --- | for a pass into the (sometimes obscure, sometimes abbreviated) name used in the LLVM C interface. --- | This translation includes, by choice of prefix, whether the C interface implementation is found in --- | the LLVM distribution ("LLVM" prefix) or either not available or broken there and so implemented --- | as part of this Haskell package ("LLVM_Hs_" prefix). -cName :: String -> String -cName n = - let core = case n of - "AddressSanitizer" -> "AddressSanitizerFunction" - "AggressiveDeadCodeElimination" -> "AggressiveDCE" - "AlwaysInline" -> "AlwaysInliner" - "DeadInstructionElimination" -> "DeadInstElimination" - "EarlyCommonSubexpressionElimination" -> "EarlyCSE" - "FunctionAttributes" -> "FunctionAttrs" - "GlobalDeadCodeElimination" -> "GlobalDCE" - "InductionVariableSimplify" -> "IndVarSimplify" - "InternalizeFunctions" -> "Internalize" - "InterproceduralSparseConditionalConstantPropagation" -> "IPSCCP" - "LoopClosedSingleStaticAssignment" -> "LCSSA" - "LoopInvariantCodeMotion" -> "LICM" - "LoopInstructionSimplify" -> "LoopInstSimplify" - "MemcpyOptimization" -> "MemCpyOpt" - "PruneExceptionHandling" -> "PruneEH" - "ScalarReplacementOfAggregates" -> "SROA" - "OldScalarReplacementOfAggregates" -> "ScalarReplAggregates" - "SimplifyControlFlowGraph" -> "CFGSimplification" - "SparseConditionalConstantPropagation" -> "SCCP" - "SuperwordLevelParallelismVectorize" -> "SLPVectorize" - h -> h - patchImpls = [ - "AddressSanitizer", - "AddressSanitizerModule", - "BoundsChecking", - "CodeGenPrepare", - "GlobalValueNumbering", - "InternalizeFunctions", - "BasicBlockVectorize", - "BlockPlacement", - "BreakCriticalEdges", - "DeadCodeElimination", - "DeadInstructionElimination", - "DemoteRegisterToMemory", - "EdgeProfiler", - "GCOVProfiler", - "LoopClosedSingleStaticAssignment", - "LoopInstructionSimplify", - "LoopStrengthReduce", - "LoopVectorize", - "LowerAtomic", - "LowerInvoke", - "LowerSwitch", - "MemorySanitizer", - "MergeFunctions", - "OptimalEdgeProfiler", - "PathProfiler", - "PartialInlining", - "ScalarReplacementOfAggregates", - "Sinking", - "StripDeadDebugInfo", - "StripDebugDeclare", - "StripNonDebugSymbols", - "ThreadSanitizer" - ] - in - (if (n `elem` patchImpls) then "LLVM_Hs_" else "LLVM") ++ "Add" ++ core ++ "Pass" diff --git a/llvm-hs/src/LLVM/Internal/FFI/Type.hs b/llvm-hs/src/LLVM/Internal/FFI/Type.hs index 96e13c0b..73ab48f6 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/Type.hs +++ b/llvm-hs/src/LLVM/Internal/FFI/Type.hs @@ -57,6 +57,12 @@ newtype AddrSpace = AddrSpace CUInt foreign import ccall unsafe "LLVMPointerType" pointerType :: Ptr Type -> AddrSpace -> IO (Ptr Type) +foreign import ccall unsafe "LLVM_Hs_OpaquePointerType" opaquePointerType :: + Ptr Context -> AddrSpace -> IO (Ptr Type) + +foreign import ccall unsafe "LLVM_Hs_IsOpaquePointerType" isOpaquePointerType :: + Ptr Type -> IO LLVMBool + -- | foreign import ccall unsafe "LLVMGetPointerAddressSpace" getPointerAddressSpace :: Ptr Type -> IO AddrSpace diff --git a/llvm-hs/src/LLVM/Internal/FFI/TypeC.cpp b/llvm-hs/src/LLVM/Internal/FFI/TypeC.cpp index 1ca661da..8d529e9e 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/TypeC.cpp +++ b/llvm-hs/src/LLVM/Internal/FFI/TypeC.cpp @@ -24,6 +24,14 @@ LLVMTypeRef LLVM_Hs_ArrayType(LLVMTypeRef ElementType, uint64_t ElementCount) { return wrap(ArrayType::get(unwrap(ElementType), ElementCount)); } +LLVMTypeRef LLVM_Hs_OpaquePointerType(LLVMContextRef C, unsigned AddrSpace) { + return wrap(PointerType::get(*unwrap(C), AddrSpace)); +} + +LLVMBool LLVM_Hs_IsOpaquePointerType(LLVMTypeRef type) { + return unwrap(type)->isOpaquePointerTy(); +} + uint64_t LLVM_Hs_GetArrayLength(LLVMTypeRef ArrayTy) { return unwrap(ArrayTy)->getNumElements(); } diff --git a/llvm-hs/src/LLVM/Internal/FFI/Value.hs b/llvm-hs/src/LLVM/Internal/FFI/Value.hs index fcd88ebb..88f739d3 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/Value.hs +++ b/llvm-hs/src/LLVM/Internal/FFI/Value.hs @@ -27,7 +27,7 @@ foreign import ccall unsafe "LLVMSetValueName" setValueName :: Ptr Value -> CString -> IO () -- | This function exposes the ID returned by llvm::Value::getValueID() --- | . +-- | . foreign import ccall unsafe "LLVM_Hs_GetValueSubclassId" getValueSubclassId :: Ptr Value -> IO ValueSubclassId diff --git a/llvm-hs/src/LLVM/Internal/Global.hs b/llvm-hs/src/LLVM/Internal/Global.hs index bf69cdc5..fe48fdff 100644 --- a/llvm-hs/src/LLVM/Internal/Global.hs +++ b/llvm-hs/src/LLVM/Internal/Global.hs @@ -19,6 +19,7 @@ import qualified LLVM.Internal.FFI.GlobalValue as FFI import LLVM.Internal.Coding import LLVM.Internal.DecodeAST import LLVM.Internal.EncodeAST +import LLVM.Internal.Type () import qualified LLVM.AST.Linkage as A.L import qualified LLVM.AST.Visibility as A.V @@ -26,6 +27,7 @@ import qualified LLVM.AST.COMDAT as A.COMDAT import qualified LLVM.AST.DLL as A.DLL import qualified LLVM.AST.ThreadLocalStorage as A.TLS import qualified LLVM.AST.Global as A.G +import qualified LLVM.AST.Type as A.T genCodingInstance [t| A.L.Linkage |] ''FFI.Linkage [ (FFI.linkageExternal, A.L.External), @@ -46,7 +48,7 @@ getLinkage g = liftIO $ decodeM =<< FFI.getLinkage (FFI.upCast g) setLinkage :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> A.L.Linkage -> EncodeAST () setLinkage g l = liftIO . FFI.setLinkage (FFI.upCast g) =<< encodeM l - + genCodingInstance [t| A.V.Visibility |] ''FFI.Visibility [ (FFI.visibilityDefault, A.V.Default), (FFI.visibilityHidden, A.V.Hidden), @@ -91,7 +93,7 @@ genCodingInstance [t| A.COMDAT.SelectionKind |] ''FFI.COMDATSelectionKind [ (FFI.comdatSelectionKindAny, A.COMDAT.Any), (FFI.comdatSelectionKindExactMatch, A.COMDAT.ExactMatch), (FFI.comdatSelectionKindLargest, A.COMDAT.Largest), - (FFI.comdatSelectionKindNoDuplicates, A.COMDAT.NoDuplicates), + (FFI.comdatSelectionKindNoDeduplicate, A.COMDAT.NoDuplicates), (FFI.comdatSelectionKindSameSize, A.COMDAT.SameSize) ] @@ -146,3 +148,6 @@ genCodingInstance [t| Maybe A.G.UnnamedAddr |] ''FFI.UnnamedAddr [ (FFI.unnamedAddrLocal, Just A.G.LocalAddr), (FFI.unnamedAddrGlobal, Just A.G.GlobalAddr) ] + +typeOfGlobal :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST A.T.Type +typeOfGlobal = decodeM <=< liftIO . FFI.getGlobalValueType . FFI.upCast diff --git a/llvm-hs/src/LLVM/Internal/InlineAssembly.hs b/llvm-hs/src/LLVM/Internal/InlineAssembly.hs index 4901ea36..39a11c5a 100644 --- a/llvm-hs/src/LLVM/Internal/InlineAssembly.hs +++ b/llvm-hs/src/LLVM/Internal/InlineAssembly.hs @@ -4,7 +4,7 @@ OverloadedStrings #-} module LLVM.Internal.InlineAssembly where - + import LLVM.Prelude import Control.Monad.IO.Class @@ -21,12 +21,11 @@ import qualified LLVM.Internal.FFI.PtrHierarchy as FFI import qualified LLVM.AST as A (Definition(..)) import qualified LLVM.AST.InlineAssembly as A -import qualified LLVM.AST.Type as A -import LLVM.Internal.Coding +import LLVM.Internal.Coding import LLVM.Internal.EncodeAST import LLVM.Internal.DecodeAST -import LLVM.Internal.Value +import LLVM.Internal.Type () genCodingInstance [t| A.Dialect |] ''FFI.AsmDialect [ (FFI.asmDialectATT, A.ATTDialect), @@ -53,7 +52,7 @@ instance EncodeM EncodeAST A.InlineAssembly (Ptr FFI.InlineAsm) where instance DecodeM DecodeAST A.InlineAssembly (Ptr FFI.InlineAsm) where decodeM p = do return A.InlineAssembly - `ap` (liftM (\(A.PointerType f _) -> f) (typeOf p)) + `ap` (decodeM =<< liftIO (FFI.getInlineAsmFunctionType p)) `ap` (decodeM =<< liftIO (FFI.getInlineAsmAssemblyString p)) `ap` (decodeM =<< liftIO (FFI.getInlineAsmConstraintString p)) `ap` (decodeM =<< liftIO (FFI.inlineAsmHasSideEffects p)) diff --git a/llvm-hs/src/LLVM/Internal/Instruction.hs b/llvm-hs/src/LLVM/Internal/Instruction.hs index d91f9325..39f45a75 100644 --- a/llvm-hs/src/LLVM/Internal/Instruction.hs +++ b/llvm-hs/src/LLVM/Internal/Instruction.hs @@ -137,6 +137,7 @@ instance DecodeM DecodeAST A.Terminator (Ptr FFI.Instruction) where cc <- decodeM =<< liftIO (FFI.getCallSiteCallingConvention i) attrs <- callInstAttributeList i fv <- liftIO $ FFI.getCallSiteCalledValue i + ty <- decodeM =<< liftIO (FFI.getCalledFunctionType i) f <- decodeM fv let argIndices = if nOps >= 4 then [0 .. nOps - 4] else [] args <- @@ -147,6 +148,7 @@ instance DecodeM DecodeAST A.Terminator (Ptr FFI.Instruction) where return A.Invoke { A.callingConvention' = cc, A.returnAttributes' = returnAttributes attrs, + A.type'' = ty, A.function' = f, A.arguments' = args, A.functionAttributes' = functionAttributes attrs, @@ -236,6 +238,7 @@ instance EncodeM EncodeAST A.Terminator (Ptr FFI.Instruction) where A.Invoke { A.callingConvention' = cc, A.returnAttributes' = rAttrs, + A.type'' = ty, A.function' = fun, A.arguments' = args, A.functionAttributes' = fAttrs, @@ -243,11 +246,12 @@ instance EncodeM EncodeAST A.Terminator (Ptr FFI.Instruction) where A.exceptionDest = ed } -> do fv <- encodeM fun + tb <- encodeM ty rb <- encodeM rd eb <- encodeM ed let (argvs, argAttrs) = unzip args (n, argvs) <- encodeM argvs - i <- liftIO $ FFI.buildInvoke builder fv argvs n rb eb s + i <- liftIO $ FFI.buildInvoke builder tb fv argvs n rb eb s attrs <- encodeM $ AttributeList fAttrs rAttrs argAttrs liftIO $ FFI.setCallSiteAttributeList i attrs cc <- encodeM cc @@ -360,7 +364,10 @@ $(do t <- typeOf v return $ case t of { A.ArrayType _ _ -> A.Filter; _ -> A.Catch} $ c |]) "functionAttributes" -> (["attrs"], [| return $ functionAttributes $(TH.dyn "attrs") |]) - "type'" -> ([], [| return t |]) + "type'" -> ([], case lrn of + "GetElementPtr" -> [| decodeM =<< liftIO (FFI.getGEPSourceElementType i) |] + "Call" -> [| decodeM =<< liftIO (FFI.getCalledFunctionType i) |] + _ -> [| return t |]) "incomingValues" -> ([], [| do n <- liftIO $ FFI.countIncoming i @@ -476,6 +483,7 @@ $(do A.tailCallKind = tck, A.callingConvention = cc, A.returnAttributes = rAttrs, + A.type' = ty, A.function = f, A.arguments = args, A.functionAttributes = fAttrs @@ -483,7 +491,8 @@ $(do fv <- encodeM f let (argvs, argAttrs) = unzip args (n, argvs) <- encodeM argvs - i <- liftIO $ FFI.buildCall builder fv argvs n s + tb <- encodeM ty + i <- liftIO $ FFI.buildCall builder tb fv argvs n s attrs <- encodeM $ AttributeList fAttrs rAttrs argAttrs liftIO $ FFI.setCallSiteAttributeList i attrs tck <- encodeM tck diff --git a/llvm-hs/src/LLVM/Internal/Module.hs b/llvm-hs/src/LLVM/Internal/Module.hs index fe690451..ebae63d8 100644 --- a/llvm-hs/src/LLVM/Internal/Module.hs +++ b/llvm-hs/src/LLVM/Internal/Module.hs @@ -48,6 +48,7 @@ import LLVM.Internal.DecodeAST import LLVM.Internal.EncodeAST import LLVM.Internal.Function import LLVM.Internal.Global +import LLVM.Internal.Type import LLVM.Internal.Instruction () import qualified LLVM.Internal.MemoryBuffer as MB import LLVM.Internal.Metadata @@ -55,8 +56,6 @@ import LLVM.Internal.Operand import LLVM.Internal.RawOStream import LLVM.Internal.String import LLVM.Internal.Target -import LLVM.Internal.Type -import LLVM.Internal.Value import LLVM.DataLayout import LLVM.Exception @@ -399,7 +398,8 @@ decodeGlobalVariables :: Ptr FFI.Module -> DecodeAST (DecodeAST [A.G.Global]) decodeGlobalVariables mod = do ffiGlobals <- liftIO $ FFI.getXs (FFI.getFirstGlobal mod) FFI.getNextGlobal fmap sequence . forM ffiGlobals $ \g -> do - A.PointerType t as <- typeOf g + t <- typeOfGlobal g + as <- decodeM =<< (liftIO $ FFI.getGlobalValueAddressSpace $ FFI.upCast g) n <- getGlobalName g return $ A.GlobalVariable @@ -429,7 +429,8 @@ decodeGlobalAliases mod = do ffiAliases <- liftIO $ FFI.getXs (FFI.getFirstAlias mod) FFI.getNextAlias fmap sequence . forM ffiAliases $ \a -> do n <- getGlobalName a - A.PointerType t as <- typeOf a + t <- typeOfGlobal a + as <- decodeM =<< (liftIO $ FFI.getGlobalValueAddressSpace $ FFI.upCast a) return $ A.G.GlobalAlias <$> return n @@ -466,7 +467,7 @@ decodeFunctions mod = do liftIO $ FFI.getXs (FFI.getFirstFunction mod) FFI.getNextFunction fmap sequence . forM ffiFunctions $ \f -> localScope $ do - A.PointerType (A.FunctionType returnType _ isVarArg) _ <- typeOf f + A.FunctionType returnType _ isVarArg <- typeOfGlobal f n <- getGlobalName f AttributeList fAttrs rAttrs pAttrs <- getAttributeList f parameters <- getParameters f pAttrs @@ -564,3 +565,9 @@ moduleAST m = runDecodeAST $ do metadata ++ functionAttributes ++ comdats) + +-- | Dump LLVM IR contained in a module to standard error output (stderr). +dumpModule :: Module -> IO () +dumpModule m = do + mPtr <- readModule m + FFI.dumpModule mPtr diff --git a/llvm-hs/src/LLVM/Internal/Operand.hs b/llvm-hs/src/LLVM/Internal/Operand.hs index 5de79bb5..7f583dfa 100644 --- a/llvm-hs/src/LLVM/Internal/Operand.hs +++ b/llvm-hs/src/LLVM/Internal/Operand.hs @@ -841,8 +841,8 @@ instance EncodeM EncodeAST A.DITemplateParameter (Ptr FFI.DITemplateParameter) w ty <- encodeM (A.type' (p :: A.DITemplateParameter)) Context c <- gets encodeStateContext case p of - A.DITemplateTypeParameter {} -> - FFI.upCast <$> liftIO (FFI.getDITemplateTypeParameter c name' ty) + A.DITemplateTypeParameter _ _ -> do + FFI.upCast <$> liftIO (FFI.getDITemplateTypeParameter c name' ty True) A.DITemplateValueParameter {..} -> do tag <- encodeM tag value <- encodeM value diff --git a/llvm-hs/src/LLVM/Internal/PassManager.hs b/llvm-hs/src/LLVM/Internal/PassManager.hs deleted file mode 100644 index 528fffd4..00000000 --- a/llvm-hs/src/LLVM/Internal/PassManager.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE - TemplateHaskell, - MultiParamTypeClasses, - CPP - #-} -module LLVM.Internal.PassManager where - -import LLVM.Prelude - -import qualified Language.Haskell.TH as TH - -import Control.Monad.AnyCont -import Control.Monad.Catch -import Control.Monad.IO.Class - -import qualified Data.ByteString.Short as ByteString - -import Foreign.C (CString) -import Foreign.Ptr -import GHC.Stack - -import qualified LLVM.Internal.FFI.PassManager as FFI -import qualified LLVM.Internal.FFI.Transforms as FFI - -import LLVM.Exception -import LLVM.Internal.Module -import LLVM.Internal.Target -import LLVM.Internal.Coding -import LLVM.Transforms - -import LLVM.AST.DataLayout - --- | --- Note: a PassManager does substantive behind-the-scenes work, arranging for the --- results of various analyses to be available as needed by transform passes, shared --- as possible. -newtype PassManager = PassManager (Ptr FFI.PassManager) - --- | There are different ways to get a 'PassManager'. This type embodies them. -data PassSetSpec - -- | a 'PassSetSpec' is a lower-level, detailed specification of a set of passes. It - -- allows fine-grained control of what passes are to be run when, and the specification - -- of passes not available through 'CuratedPassSetSpec'. - = PassSetSpec { - transforms :: [Pass], - dataLayout :: Maybe DataLayout, - targetLibraryInfo :: Maybe TargetLibraryInfo, - targetMachine :: Maybe TargetMachine - } - -- | This type is a high-level specification of a set of passes. It uses the same - -- collection of passes chosen by the LLVM team in the command line tool 'opt'. The fields - -- of this spec are much like typical compiler command-line flags - e.g. -O\, etc. - | CuratedPassSetSpec { - optLevel :: Maybe Word, - sizeLevel :: Maybe Word, - unitAtATime :: Maybe Bool, - simplifyLibCalls :: Maybe Bool, - loopVectorize :: Maybe Bool, - superwordLevelParallelismVectorize :: Maybe Bool, - useInlinerWithThreshold :: Maybe Word, - dataLayout :: Maybe DataLayout, - targetLibraryInfo :: Maybe TargetLibraryInfo, - targetMachine :: Maybe TargetMachine - } - --- | Helper to make a curated 'PassSetSpec' -defaultCuratedPassSetSpec :: PassSetSpec -defaultCuratedPassSetSpec = CuratedPassSetSpec { - optLevel = Nothing, - sizeLevel = Nothing, - unitAtATime = Nothing, - simplifyLibCalls = Nothing, - loopVectorize = Nothing, - superwordLevelParallelismVectorize = Nothing, - useInlinerWithThreshold = Nothing, - dataLayout = Nothing, - targetLibraryInfo = Nothing, - targetMachine = Nothing -} - --- | an empty 'PassSetSpec' -defaultPassSetSpec :: PassSetSpec -defaultPassSetSpec = PassSetSpec { - transforms = [], - dataLayout = Nothing, - targetLibraryInfo = Nothing, - targetMachine = Nothing -} - -instance (Monad m, MonadThrow m, MonadAnyCont IO m) => EncodeM m GCOVVersion CString where - encodeM (GCOVVersion cs) - | ByteString.length cs == 4 = encodeM cs - | otherwise = throwM (EncodeException "GCOVVersion should consist of exactly 4 characters") - -createPassManager :: HasCallStack => PassSetSpec -> IO (Ptr FFI.PassManager) -createPassManager pss = runAnyContT' return $ do - pm <- liftIO $ FFI.createPassManager - forM_ (targetLibraryInfo pss) $ \(TargetLibraryInfo tli) -> do - liftIO $ FFI.addTargetLibraryInfoPass pm tli - forM_ (targetMachine pss) $ \(TargetMachine tm) -> liftIO $ FFI.addAnalysisPasses tm pm - case pss of - s@CuratedPassSetSpec {} -> liftIO $ do - bracket FFI.passManagerBuilderCreate FFI.passManagerBuilderDispose $ \b -> do - let handleOption g m = forM_ (m s) (g b <=< encodeM) - handleOption FFI.passManagerBuilderSetOptLevel optLevel - handleOption FFI.passManagerBuilderSetSizeLevel sizeLevel - handleOption FFI.passManagerBuilderSetDisableUnitAtATime (liftM not . unitAtATime) - handleOption FFI.passManagerBuilderSetDisableSimplifyLibCalls (liftM not . simplifyLibCalls) - handleOption FFI.passManagerBuilderUseInlinerWithThreshold useInlinerWithThreshold - handleOption FFI.passManagerBuilderSetLoopVectorize loopVectorize - handleOption FFI.passManagerBuilderSetSuperwordLevelParallelismVectorize superwordLevelParallelismVectorize - FFI.passManagerBuilderPopulateModulePassManager b pm - PassSetSpec ps _ _ tm' -> do - let tm = maybe nullPtr (\(TargetMachine tm) -> tm) tm' - forM_ ps $ \p -> $( - do -#if __GLASGOW_HASKELL__ < 800 - TH.TyConI (TH.DataD _ _ _ cons _) <- TH.reify ''Pass -#else - TH.TyConI (TH.DataD _ _ _ _ cons _) <- TH.reify ''Pass -#endif - TH.caseE [| p |] $ flip map cons $ \con -> do - let - (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 ] - ++ [ - TH.noBindS [| - liftIO $( - foldl1 TH.appE - (map TH.dyn $ - ["FFI.add" ++ TH.nameBase n ++ "Pass", "pm"] - ++ ["tm" | FFI.needsTargetMachine (TH.nameBase n)] - ++ fns) - ) - |] - ] - TH.match (TH.conP n $ map (TH.varP . TH.mkName) fns) (TH.normalB (TH.doE actions)) [] - ) - return pm - --- | bracket the creation of a 'PassManager' -withPassManager :: PassSetSpec -> (PassManager -> IO a) -> IO a -withPassManager s = bracket (createPassManager s) FFI.disposePassManager . (. PassManager) - --- | run the passes in a 'PassManager' on a 'Module', modifying the 'Module'. -runPassManager :: PassManager -> Module -> IO Bool -runPassManager (PassManager p) m = do - m' <- readModule m - toEnum . fromIntegral <$> FFI.runPassManager p m' diff --git a/llvm-hs/src/LLVM/Internal/Passes.hs b/llvm-hs/src/LLVM/Internal/Passes.hs new file mode 100644 index 00000000..41c51bd2 --- /dev/null +++ b/llvm-hs/src/LLVM/Internal/Passes.hs @@ -0,0 +1,51 @@ +-- | This module provides an interface to LLVM's passes. +module LLVM.Internal.Passes where + +import LLVM.Prelude + +import Foreign.C.String +import Foreign.C.Types +import Foreign.Marshal.Array +import Foreign.Ptr + +import LLVM.Internal.Module +import LLVM.Internal.Target + +import qualified LLVM.Internal.FFI.Passes as FFI + +data ModulePass + = GlobalDeadCodeElimination + | InternalizeFunctions { exportList :: [String] } + | AlwaysInline { insertLifetime :: Bool } + | CuratedPassSet { optLevel :: Word } + +data PassSetSpec + = PassSetSpec { + passes :: [ModulePass], + targetMachine :: Maybe TargetMachine + } + +runPasses :: PassSetSpec -> Module -> IO () +runPasses (PassSetSpec passes tm) m = do + m' <- readModule m + pb <- FFI.createPassBuilderPackage tm' + mpm <- FFI.createModulePassManager + forM_ passes $ addPass mpm pb + FFI.modulePassManagerRun mpm pb m' + FFI.disposeModulePassManager mpm + FFI.disposePassBuilderPackage pb + where tm' = case tm of Nothing -> nullPtr; Just (TargetMachine ptr) -> ptr + +addPass :: Ptr FFI.ModulePassManager -> Ptr FFI.PassBuilderPackage -> ModulePass -> IO () +addPass mpm pb p = case p of + CuratedPassSet level -> FFI.addPerModuleDefaultPipeline mpm pb (fromIntegral level) + GlobalDeadCodeElimination -> FFI.addGlobalDeadCodeEliminationPass mpm + AlwaysInline l -> FFI.addAlwaysInlinePass mpm (if l then 1 else 0) + InternalizeFunctions exports -> encodeExports exports $ FFI.addInternalizeFunctionsPass mpm + +encodeExports :: [String] -> (CInt -> Ptr CString -> IO a) -> IO a +encodeExports topExports cont = go [] topExports + where + go ptrs exports = case exports of + [] -> withArrayLen ptrs $ \n p -> cont (fromIntegral n) p + (e:es) -> withCString e $ \ep -> go (ep:ptrs) es diff --git a/llvm-hs/src/LLVM/Internal/Target.hs b/llvm-hs/src/LLVM/Internal/Target.hs index 39b524df..bb07bd0a 100644 --- a/llvm-hs/src/LLVM/Internal/Target.hs +++ b/llvm-hs/src/LLVM/Internal/Target.hs @@ -79,8 +79,7 @@ genCodingInstance [t| TO.FloatingPointOperationFusionMode |] ''FFI.FPOpFusionMod genCodingInstance[t| TO.DebugCompressionType |] ''FFI.DebugCompressionType [ (FFI.debugCompressionTypeNone, TO.CompressNone), - (FFI.debugCompressionTypeGNU, TO.CompressGNU), - (FFI.debugCompressionTypeZ, TO.CompressZ) + (FFI.debugCompressionTypeZlib, TO.CompressZlib) ] genCodingInstance[t| TO.ThreadModel |] ''FFI.ThreadModel [ @@ -191,7 +190,6 @@ pokeTargetOptions hOpts opts@(TargetOptions cOpts) = do (FFI.targetOptionFlagEmulatedTLS, TO.emulatedThreadLocalStorage), (FFI.targetOptionFlagEnableIPRA, TO.enableInterProceduralRegisterAllocation) ] - 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) @@ -203,21 +201,21 @@ pokeTargetOptions hOpts opts@(TargetOptions cOpts) = do pokeMachineCodeOptions (TO.machineCodeOptions hOpts) =<< machineCodeOptions opts pokeMachineCodeOptions :: TO.MachineCodeOptions -> MCTargetOptions -> IO () -pokeMachineCodeOptions hOpts (MCTargetOptions cOpts) = - mapM_ (\(c, ha) -> FFI.setMCTargetOptionFlag cOpts c =<< encodeM (ha hOpts)) [ +pokeMachineCodeOptions hOpts (MCTargetOptions cOpts) = do + mapM_ (\(c, ha) -> FFI.setMCTargetOptionBoolFlag cOpts c =<< encodeM (ha hOpts)) [ (FFI.mcTargetOptionFlagMCRelaxAll, TO.relaxAll), (FFI.mcTargetOptionFlagMCNoExecStack, TO.noExecutableStack), (FFI.mcTargetOptionFlagMCFatalWarnings, TO.fatalWarnings), (FFI.mcTargetOptionFlagMCNoWarn, TO.noWarnings), (FFI.mcTargetOptionFlagMCNoDeprecatedWarn, TO.noDeprecatedWarning), (FFI.mcTargetOptionFlagMCSaveTempLabels, TO.saveTemporaryLabels), - (FFI.mcTargetOptionFlagMCUseDwarfDirectory, TO.useDwarfDirectory), (FFI.mcTargetOptionFlagMCIncrementalLinkerCompatible, TO.incrementalLinkerCompatible), (FFI.mcTargetOptionFlagShowMCEncoding, TO.showMachineCodeEncoding), (FFI.mcTargetOptionFlagShowMCInst, TO.showMachineCodeInstructions), (FFI.mcTargetOptionFlagAsmVerbose, TO.verboseAssembly), (FFI.mcTargetOptionFlagPreserveAsmComments, TO.preserveComentsInAssembly) ] + FFI.setMCTargetOptionFlagUseDwarfDirectory cOpts $ fromIntegral $ fromEnum $ TO.useDwarfDirectory hOpts -- | get all target options peekTargetOptions :: TargetOptions -> IO TO.Options @@ -262,7 +260,6 @@ peekTargetOptions opts@(TargetOptions tOpts) = do <- gof FFI.targetOptionFlagEmulatedTLS enableInterProceduralRegisterAllocation <- gof FFI.targetOptionFlagEnableIPRA - stackAlignmentOverride <- decodeM =<< FFI.getStackAlignmentOverride tOpts floatABIType <- decodeM =<< FFI.getFloatABIType tOpts allowFloatingPointOperationFusion <- decodeM =<< FFI.getAllowFPOpFusion tOpts threadModel <- decodeM =<< FFI.getThreadModel tOpts @@ -276,7 +273,7 @@ peekTargetOptions opts@(TargetOptions tOpts) = do -- | get all machine code options peekMachineCodeOptions :: MCTargetOptions -> IO TO.MachineCodeOptions peekMachineCodeOptions (MCTargetOptions tOpts) = do - let gof = decodeM <=< FFI.getMCTargetOptionsFlag tOpts + let gof = decodeM <=< FFI.getMCTargetOptionsBoolFlag tOpts relaxAll <- gof FFI.mcTargetOptionFlagMCRelaxAll noExecutableStack @@ -290,7 +287,7 @@ peekMachineCodeOptions (MCTargetOptions tOpts) = do saveTemporaryLabels <- gof FFI.mcTargetOptionFlagMCSaveTempLabels useDwarfDirectory - <- gof FFI.mcTargetOptionFlagMCUseDwarfDirectory + <- toEnum . fromIntegral <$> FFI.getMCTargetOptionFlagUseDwarfDirectory tOpts incrementalLinkerCompatible <- gof FFI.mcTargetOptionFlagMCIncrementalLinkerCompatible showMachineCodeEncoding diff --git a/llvm-hs/src/LLVM/Internal/Type.hs b/llvm-hs/src/LLVM/Internal/Type.hs index f631f2b2..0a7eb05e 100644 --- a/llvm-hs/src/LLVM/Internal/Type.hs +++ b/llvm-hs/src/LLVM/Internal/Type.hs @@ -78,10 +78,9 @@ instance EncodeM EncodeAST A.Type (Ptr FFI.Type) where argTypes <- encodeM argTypeASTs isVarArg <- encodeM isVarArg liftIO $ FFI.functionType returnType argTypes isVarArg - A.PointerType elementType addressSpace -> do - e <- encodeM elementType + A.PointerType addressSpace -> do a <- encodeM addressSpace - liftIO $ FFI.pointerType e a + liftIO $ FFI.opaquePointerType context a A.VoidType -> liftIO $ FFI.voidTypeInContext context A.FloatingPointType A.HalfFP -> liftIO $ FFI.halfTypeInContext context A.FloatingPointType A.FloatFP -> liftIO $ FFI.floatTypeInContext context @@ -122,10 +121,9 @@ instance DecodeM DecodeAST A.Type (Ptr FFI.Type) where decodeM (n, ts) ) `ap` (decodeM =<< liftIO (FFI.isFunctionVarArg t)) - [typeKindP|Pointer|] -> - return A.PointerType - `ap` (decodeM =<< liftIO (FFI.getElementType t)) - `ap` (decodeM =<< liftIO (FFI.getPointerAddressSpace t)) + [typeKindP|Pointer|] -> do + addrSpace <- decodeM =<< liftIO (FFI.getPointerAddressSpace t) + return $ A.PointerType addrSpace [typeKindP|Half|] -> return $ A.FloatingPointType A.HalfFP [typeKindP|Float|] -> return $ A.FloatingPointType A.FloatFP [typeKindP|Double|] -> return $ A.FloatingPointType A.DoubleFP @@ -166,7 +164,7 @@ createNamedType n = do renameType :: A.Type -> EncodeAST A.Type renameType A.VoidType = pure A.VoidType renameType t@(A.IntegerType _) = pure t -renameType (A.PointerType r a) = fmap (\r' -> A.PointerType r' a) (renameType r) +renameType t@(A.PointerType _) = pure t renameType t@(A.FloatingPointType _) = pure t renameType (A.FunctionType r as varArg) = liftA2 diff --git a/llvm-hs/src/LLVM/Internal/Value.hs b/llvm-hs/src/LLVM/Internal/Value.hs index fdf65e85..1f35efd3 100644 --- a/llvm-hs/src/LLVM/Internal/Value.hs +++ b/llvm-hs/src/LLVM/Internal/Value.hs @@ -14,10 +14,9 @@ import qualified LLVM.Internal.FFI.Value as FFI import LLVM.Internal.Coding import LLVM.Internal.DecodeAST -import LLVM.Internal.Type () +import LLVM.Internal.Type () import qualified LLVM.AST.Type as A typeOf :: FFI.DescendentOf FFI.Value v => Ptr v -> DecodeAST A.Type typeOf = decodeM <=< liftIO . FFI.typeOf . FFI.upCast - diff --git a/llvm-hs/src/LLVM/Module.hs b/llvm-hs/src/LLVM/Module.hs index 562ca8c9..d3b8db51 100644 --- a/llvm-hs/src/LLVM/Module.hs +++ b/llvm-hs/src/LLVM/Module.hs @@ -25,7 +25,9 @@ module LLVM.Module ( moduleObject, writeObjectToFile, - linkModules + linkModules, + + dumpModule ) where import LLVM.Internal.Module diff --git a/llvm-hs/src/LLVM/PassManager.hs b/llvm-hs/src/LLVM/PassManager.hs deleted file mode 100644 index cb948acf..00000000 --- a/llvm-hs/src/LLVM/PassManager.hs +++ /dev/null @@ -1,14 +0,0 @@ --- | A 'PassManager' holds collection of passes, to be run on 'Module's. --- Build one with 'withPassManager': --- --- * using 'CuratedPassSetSpec' if you want optimization but not to play with your compiler --- --- * using 'PassSetSpec' if you do want to play with your compiler -module LLVM.PassManager ( - PassManager, - PassSetSpec(..), defaultPassSetSpec, defaultCuratedPassSetSpec, - withPassManager, - runPassManager - ) where - -import LLVM.Internal.PassManager diff --git a/llvm-hs/src/LLVM/Passes.hs b/llvm-hs/src/LLVM/Passes.hs new file mode 100644 index 00000000..5405995e --- /dev/null +++ b/llvm-hs/src/LLVM/Passes.hs @@ -0,0 +1,4 @@ +-- | This module provides an interface to LLVM's passes. +module LLVM.Passes (PassSetSpec (..), ModulePass (..), runPasses) where + +import LLVM.Internal.Passes diff --git a/llvm-hs/src/LLVM/Target/Options.hs b/llvm-hs/src/LLVM/Target/Options.hs index fa731d61..f187a85e 100644 --- a/llvm-hs/src/LLVM/Target/Options.hs +++ b/llvm-hs/src/LLVM/Target/Options.hs @@ -20,8 +20,7 @@ data FloatingPointOperationFusionMode -- | data DebugCompressionType = CompressNone -- ^ No compression - | CompressGNU -- ^ zlib-gnu style compression - | CompressZ -- ^ zlib style compression + | CompressZlib -- ^ zlib style compression deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic) -- | @@ -86,7 +85,6 @@ data Options = Options { trapUnreachable :: Bool, emulatedThreadLocalStorage :: Bool, enableInterProceduralRegisterAllocation :: Bool, - stackAlignmentOverride :: Word32, floatABIType :: FloatABI, allowFloatingPointOperationFusion :: FloatingPointOperationFusionMode, threadModel :: ThreadModel, @@ -98,6 +96,12 @@ data Options = Options { } deriving (Eq, Ord, Read, Show) +data DwarfDirectory + = DisableDwarfDirectory + | EnableDwarfDirectory + | DefaultDwarfDirectory -- ^ target specific + deriving (Eq, Ord, Read, Show, Enum, Bounded) + -- | data MachineCodeOptions = MachineCodeOptions { relaxAll :: Bool, @@ -106,7 +110,7 @@ data MachineCodeOptions = MachineCodeOptions { noWarnings :: Bool, noDeprecatedWarning :: Bool, saveTemporaryLabels :: Bool, - useDwarfDirectory :: Bool, + useDwarfDirectory :: DwarfDirectory, incrementalLinkerCompatible :: Bool, showMachineCodeEncoding :: Bool, showMachineCodeInstructions :: Bool, diff --git a/llvm-hs/src/LLVM/Transforms.hs b/llvm-hs/src/LLVM/Transforms.hs deleted file mode 100644 index 2fa59a99..00000000 --- a/llvm-hs/src/LLVM/Transforms.hs +++ /dev/null @@ -1,149 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | This module provides an enumeration of the various transformation (e.g. optimization) passes --- provided by LLVM. They can be used to create a 'LLVM.PassManager.PassManager' to, in turn, --- run the passes on 'LLVM.Module.Module's. If you don't know what passes you want, consider --- instead using 'LLVM.PassManager.CuratedPassSetSpec'. -module LLVM.Transforms where - -import LLVM.Prelude - --- | --- A few passes can make use of information in a 'LLVM.Target.TargetMachine' if one --- is provided to 'LLVM.PassManager.createPassManager'. --- -data Pass - -- here begin the Scalar passes - = AggressiveDeadCodeElimination - | BreakCriticalEdges - -- | can use a 'LLVM.Target.TargetMachine' - | CodeGenPrepare - | CorrelatedValuePropagation - | DeadCodeElimination - | DeadStoreElimination - | DemoteRegisterToMemory - | EarlyCommonSubexpressionElimination - | GlobalValueNumbering { noLoads :: Bool } - | InductionVariableSimplify - | InstructionCombining - -- | Instruction simplification includes constant folding - | InstructionSimplify - | JumpThreading - | LoopClosedSingleStaticAssignment - | LoopInvariantCodeMotion - | LoopDeletion - | LoopIdiom - | LoopInstructionSimplify - | LoopRotate - | LoopStrengthReduce - | LoopUnroll { loopUnrollThreshold :: Maybe Word, count :: Maybe Word, allowPartial :: Maybe Bool } - | LoopUnswitch { optimizeForSize :: Bool } - | LowerAtomic - | LowerInvoke - | LowerSwitch - | LowerExpectIntrinsic - | MemcpyOptimization - | PromoteMemoryToRegister - | Reassociate - | ScalarReplacementOfAggregates { requiresDominatorTree :: Bool } - | OldScalarReplacementOfAggregates { - oldScalarReplacementOfAggregatesThreshold :: Maybe Word, - useDominatorTree :: Bool, - structMemberThreshold :: Maybe Word, - arrayElementThreshold :: Maybe Word, - scalarLoadThreshold :: Maybe Word - } - | SparseConditionalConstantPropagation - | SimplifyLibCalls - | SimplifyControlFlowGraph - | Sinking - | TailCallElimination - - -- here begin the Interprocedural passes - | AlwaysInline { insertLifetime :: Bool } - | ArgumentPromotion - | ConstantMerge - | FunctionAttributes - | FunctionInlining { - functionInliningThreshold :: Word - } - | GlobalDeadCodeElimination - | InternalizeFunctions { exportList :: [String] } - | InterproceduralSparseConditionalConstantPropagation - | MergeFunctions - | PartialInlining - | PruneExceptionHandling - | StripDeadDebugInfo - | StripDebugDeclare - | StripNonDebugSymbols - | StripSymbols { onlyDebugInfo :: Bool } - - -- here begin the vectorization passes - | LoopVectorize { - interleaveOnlyWhenForced :: Bool, - vectorizeOnlyWhenForced :: Bool - } - | SuperwordLevelParallelismVectorize - - -- here begin the instrumentation passes - | GCOVProfiler { - emitNotes :: Bool, - emitData :: Bool, - version :: GCOVVersion, - noRedZone :: Bool, - atomic :: Bool, - filter :: String, - exclude :: String - } - | AddressSanitizer - | AddressSanitizerModule - | MemorySanitizer { - trackOrigins :: Bool, - recover :: Bool, - kernel :: Bool - } - | ThreadSanitizer - | BoundsChecking - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - --- | Defaults for the 'LoopVectorize' pass -defaultLoopVectorize :: Pass -defaultLoopVectorize = LoopVectorize { - interleaveOnlyWhenForced = False, - vectorizeOnlyWhenForced = False - } - --- | See . -newtype GCOVVersion = GCOVVersion ShortByteString - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - --- | Defaults for 'GCOVProfiler'. -defaultGCOVProfiler :: Pass -defaultGCOVProfiler = GCOVProfiler { - emitNotes = True, - emitData = True, - version = GCOVVersion "402*", - noRedZone = False, - atomic = True, - LLVM.Transforms.filter = "", - exclude = "" - } - --- | Defaults for 'AddressSanitizer'. -defaultAddressSanitizer :: Pass -defaultAddressSanitizer = AddressSanitizer - --- | Defaults for 'AddressSanitizerModule'. -defaultAddressSanitizerModule :: Pass -defaultAddressSanitizerModule = AddressSanitizerModule - --- | Defaults for 'MemorySanitizer'. -defaultMemorySanitizer :: Pass -defaultMemorySanitizer = MemorySanitizer { - trackOrigins = False, - recover = False, - kernel = False -} - --- | Defaults for 'ThreadSanitizer'. -defaultThreadSanitizer :: Pass -defaultThreadSanitizer = ThreadSanitizer diff --git a/llvm-hs/test/LLVM/Test/Analysis.hs b/llvm-hs/test/LLVM/Test/Analysis.hs index 93d79e5d..f983fc24 100644 --- a/llvm-hs/test/LLVM/Test/Analysis.hs +++ b/llvm-hs/test/LLVM/Test/Analysis.hs @@ -38,8 +38,8 @@ tests = testGroup "Analysis" [ GlobalDefinition $ Function L.External V.Default CC.C [] A.T.void (Name "foo") ([ Parameter i32 (Name "x") [] ],False) - [] - Nothing 0 Nothing + [] + Nothing 0 Nothing [ BasicBlock (UnName 0) [ UnName 1 := Call { @@ -71,31 +71,33 @@ tests = testGroup "Analysis" [ let str = "; ModuleID = ''\n\ \source_filename = \"\"\n\ \\n\ - \define double @my_function2(double* %input_0) {\n\ + \define double @my_function2(ptr %input_0) {\n\ \foo:\n\ - \ %tmp_input_w0 = getelementptr inbounds double, double* %input_0, i64 0\n\ - \ %0 = load double, double* %tmp_input_w0, align 8\n\ + \ %tmp_input_w0 = getelementptr inbounds double, ptr %input_0, i64 0\n\ + \ %0 = load double, ptr %tmp_input_w0, align 8\n\ \ ret double %0\n\ \}\n" - ast = + ast = Module "" "" Nothing Nothing [ GlobalDefinition $ functionDefaults { G.returnType = double, G.name = Name "my_function2", G.parameters = ([ - Parameter (ptr double) (Name "input_0") [] + Parameter ptr (Name "input_0") [] ],False), G.basicBlocks = [ - BasicBlock (Name "foo") [ + BasicBlock (Name "foo") [ Name "tmp_input_w0" := GetElementPtr { inBounds = True, - address = LocalReference (ptr double) (Name "input_0"), + type' = double, + address = LocalReference ptr (Name "input_0"), indices = [ConstantOperand (C.Int 64 0)], metadata = [] }, UnName 0 := Load { volatile = False, - address = LocalReference (ptr double) (Name "tmp_input_w0"), + type' = double, + address = LocalReference ptr (Name "tmp_input_w0"), maybeAtomicity = Nothing, alignment = 8, metadata = [] diff --git a/llvm-hs/test/LLVM/Test/Attribute.hs b/llvm-hs/test/LLVM/Test/Attribute.hs index da75ce69..0fd81a84 100644 --- a/llvm-hs/test/LLVM/Test/Attribute.hs +++ b/llvm-hs/test/LLVM/Test/Attribute.hs @@ -49,17 +49,16 @@ moduleAst = { tailCallKind = Nothing , callingConvention = C , returnAttributes = [] + , type' = + FunctionType + { resultType = i32 + , argumentTypes = [] + , isVarArg = False + } , function = Right (ConstantOperand - (GlobalReference - (ptr - (FunctionType - { resultType = i32 - , argumentTypes = [] - , isVarArg = False - })) - ("f"))) + (GlobalReference "f")) , arguments = [] , functionAttributes = [Left (GroupID 0)] , metadata = [] @@ -106,10 +105,10 @@ moduleAst = , StackProtect , StackProtectReq , StackProtectStrong - , UWTable , WriteOnly , AllocSize 8 (Just 16) , StackAlignment 8 + , UWTable , StringAttribute "bar" "baz" , StringAttribute "foo" "" , StringAttribute "qux" "" diff --git a/llvm-hs/test/LLVM/Test/Constants.hs b/llvm-hs/test/LLVM/Test/Constants.hs index 269ea572..f02e27c2 100644 --- a/llvm-hs/test/LLVM/Test/Constants.hs +++ b/llvm-hs/test/LLVM/Test/Constants.hs @@ -117,44 +117,44 @@ tests = testGroup "Constants" [ ), ( "binop/cast", i64, - C.Add False False (C.PtrToInt (C.GlobalReference (ptr i32) (UnName 1)) i64) (C.Int 64 2), - "global i64 add (i64 ptrtoint (i32* @1 to i64), i64 2)" + C.Add False False (C.PtrToInt (C.GlobalReference (UnName 1)) i64) (C.Int 64 2), + "global i64 add (i64 ptrtoint (ptr @1 to i64), i64 2)" ), ( "binop/cast nsw", i64, - C.Add True False (C.PtrToInt (C.GlobalReference (ptr i32) (UnName 1)) i64) (C.Int 64 2), - "global i64 add nsw (i64 ptrtoint (i32* @1 to i64), i64 2)" + C.Add True False (C.PtrToInt (C.GlobalReference (UnName 1)) i64) (C.Int 64 2), + "global i64 add nsw (i64 ptrtoint (ptr @1 to i64), i64 2)" ), ( "icmp", i1, - C.ICmp IPred.SGE (C.GlobalReference (ptr i32) (UnName 1)) (C.GlobalReference (ptr i32) (UnName 2)), - "global i1 icmp sge (i32* @1, i32* @2)" + C.ICmp IPred.SGE (C.GlobalReference (UnName 1)) (C.GlobalReference (UnName 2)), + "global i1 icmp sge (ptr @1, ptr @2)" ), ( "getelementptr", - ptr i32, - C.GetElementPtr True (C.GlobalReference (ptr i32) (UnName 1)) [C.Int 64 27], - "global i32* getelementptr inbounds (i32, i32* @1, i64 27)" + ptr, + C.GetElementPtr True i32 (C.GlobalReference (UnName 1)) [C.Int 64 27], + "global ptr getelementptr inbounds (i32, ptr @1, i64 27)" ), ( "selectvalue", i32, - C.Select (C.PtrToInt (C.GlobalReference (ptr i32) (UnName 1)) i1) + C.Select (C.PtrToInt (C.GlobalReference (UnName 1)) i1) (C.Int 32 1) (C.Int 32 2), - "global i32 select (i1 ptrtoint (i32* @1 to i1), i32 1, i32 2)" + "global i32 select (i1 ptrtoint (ptr @1 to i1), i32 1, i32 2)" ), ( "extractelement", i32, C.ExtractElement (C.BitCast - (C.PtrToInt (C.GlobalReference (ptr i32) (UnName 1)) i64) + (C.PtrToInt (C.GlobalReference (UnName 1)) i64) (VectorType 2 i32)) (C.Int 32 1), - "global i32 extractelement (<2 x i32> bitcast (i64 ptrtoint (i32* @1 to i64) to <2 x i32>), i32 1)" + "global i32 extractelement (<2 x i32> bitcast (i64 ptrtoint (ptr @1 to i64) to <2 x i32>), i32 1)" ), ( "addrspacecast", - (PointerType i32 (AddrSpace 1)), - C.AddrSpaceCast (C.GlobalReference (ptr i32) (UnName 1)) (PointerType i32 (AddrSpace 1)), - "global i32 addrspace(1)* addrspacecast (i32* @1 to i32 addrspace(1)*)" + (PointerType (AddrSpace 1)), + C.AddrSpaceCast (C.GlobalReference (UnName 1)) (PointerType (AddrSpace 1)), + "global ptr addrspace(1) addrspacecast (ptr @1 to ptr addrspace(1))" {- ), ( -- This test fails since LLVM 3.2! -- LLVM parses the extractValue instruction from a file via llvm-as properly, but it does not here. diff --git a/llvm-hs/test/LLVM/Test/FunctionAttribute.hs b/llvm-hs/test/LLVM/Test/FunctionAttribute.hs index c6343834..bf09e23a 100644 --- a/llvm-hs/test/LLVM/Test/FunctionAttribute.hs +++ b/llvm-hs/test/LLVM/Test/FunctionAttribute.hs @@ -31,22 +31,30 @@ instance Arbitrary FunctionAttribute where , return Builtin , return Cold , return Convergent + , return Hot , return InaccessibleMemOnly , return InaccessibleMemOrArgMemOnly , return InlineHint , return JumpTable , return MinimizeSize + , return MustProgress , return Naked , return NoBuiltin + , return NoCallback + , return NoCfCheck , return NoDuplicate , return NoFree , return NoImplicitFloat , return NoInline - , return NonLazyBind + , return NoMerge + , return NoProfile , return NoRecurse , return NoRedZone , return NoReturn , return NoUnwind + , return NonLazyBind + , return NullPointerIsValid + , return OptForFuzzing , return OptimizeForSize , return OptimizeNone , return ReadNone @@ -55,9 +63,12 @@ instance Arbitrary FunctionAttribute where , return SafeStack , return SanitizeAddress , return SanitizeHWAddress + , return SanitizeMemTag , return SanitizeMemory , return SanitizeThread + , return ShadowCallStack , return Speculatable + , return SpeculativeLoadHardening , return StackProtect , return StackProtectReq , return StackProtectStrong @@ -67,6 +78,7 @@ instance Arbitrary FunctionAttribute where , StackAlignment <$> elements (map (2^) [0..8 :: Int]) , StringAttribute <$> (B.pack <$> arbitrary) <*> (B.pack <$> arbitrary) , suchThat (AllocSize <$> arbitrary <*> arbitrary) (/= AllocSize 0 (Just 0)) + , suchThat (VScaleRange <$> arbitrary <*> arbitrary) (\(VScaleRange l h) -> l <= h && h /= 0) ] shrink = \case diff --git a/llvm-hs/test/LLVM/Test/InlineAssembly.hs b/llvm-hs/test/LLVM/Test/InlineAssembly.hs index 8eb3892d..782bec12 100644 --- a/llvm-hs/test/LLVM/Test/InlineAssembly.hs +++ b/llvm-hs/test/LLVM/Test/InlineAssembly.hs @@ -21,7 +21,7 @@ import qualified LLVM.AST.Global as G tests = testGroup "InlineAssembly" [ testCase "expression" $ do let ast = Module "" "" Nothing Nothing [ - GlobalDefinition $ + GlobalDefinition $ functionDefaults { G.returnType = i32, G.name = Name "foo", @@ -32,6 +32,7 @@ tests = testGroup "InlineAssembly" [ tailCallKind = Nothing, callingConvention = CC.C, returnAttributes = [], + LLVM.AST.type' = FunctionType i32 [i32] False, function = Left $ InlineAssembly { IA.type' = FunctionType i32 [i32] False, assembly = "bswap $0", diff --git a/llvm-hs/test/LLVM/Test/Instructions.hs b/llvm-hs/test/LLVM/Test/Instructions.hs index dc5bc7cb..ad241bdb 100644 --- a/llvm-hs/test/LLVM/Test/Instructions.hs +++ b/llvm-hs/test/LLVM/Test/Instructions.hs @@ -58,7 +58,7 @@ tests = testGroup "Instructions" [ mStr = "; ModuleID = ''\n\ \source_filename = \"\"\n\ \\n\ - \define void @0(i32 %0, float %1, i32* %2, i64 %3, i1 %4, <2 x i32> %5, { i32, i32 } %6) {\n\ + \define void @0(i32 %0, float %1, ptr %2, i64 %3, i1 %4, <2 x i32> %5, { i32, i32 } %6) {\n\ \ " <> namedInstrS <> "\n\ \ ret void\n\ \}\n" @@ -66,7 +66,7 @@ tests = testGroup "Instructions" [ | let ts = [ i32, float, - ptr i32, + ptr, i64, i1, VectorType 2 i32, @@ -288,76 +288,84 @@ tests = testGroup "Instructions" [ ("load", Load { volatile = False, + type' = i32, address = a 2, maybeAtomicity = Nothing, alignment = 4, metadata = [] }, - "load i32, i32* %2, align 4"), + "load i32, ptr %2, align 4"), ("volatile", Load { volatile = True, + type' = i32, address = a 2, maybeAtomicity = Nothing, alignment = 4, metadata = [] }, - "load volatile i32, i32* %2, align 4"), + "load volatile i32, ptr %2, align 4"), ("acquire", Load { volatile = False, + type' = i32, address = a 2, maybeAtomicity = Just (System, Acquire), alignment = 1, metadata = [] }, - "load atomic i32, i32* %2 acquire, align 1"), + "load atomic i32, ptr %2 acquire, align 1"), ("singlethread", Load { volatile = False, + type' = i32, address = a 2, maybeAtomicity = Just (SingleThread, Monotonic), alignment = 1, metadata = [] }, - "load atomic i32, i32* %2 syncscope(\"singlethread\") monotonic, align 1"), + "load atomic i32, ptr %2 syncscope(\"singlethread\") monotonic, align 1"), ("GEP", GetElementPtr { inBounds = False, + type' = i32, address = a 2, indices = [ a 0 ], metadata = [] }, - "getelementptr i32, i32* %2, i32 %0"), + "getelementptr i32, ptr %2, i32 %0"), ("inBounds", GetElementPtr { inBounds = True, + type' = i32, address = a 2, indices = [ a 0 ], metadata = [] }, - "getelementptr inbounds i32, i32* %2, i32 %0"), + "getelementptr inbounds i32, ptr %2, i32 %0"), ("cmpxchg", CmpXchg { volatile = False, address = a 2, expected = a 0, replacement = a 0, + alignment = 16, atomicity = (System, Monotonic), failureMemoryOrdering = Monotonic, metadata = [] }, - "cmpxchg i32* %2, i32 %0, i32 %0 monotonic monotonic"), + "cmpxchg ptr %2, i32 %0, i32 %0 monotonic monotonic, align 16"), ("atomicrmw", AtomicRMW { volatile = False, rmwOperation = RMWOp.UMax, address = a 2, value = a 0, + alignment = 16, atomicity = (System, Release), metadata = [] }, - "atomicrmw umax i32* %2, i32 %0 release"), + "atomicrmw umax ptr %2, i32 %0 release, align 16"), ("trunc", Trunc { @@ -428,14 +436,14 @@ tests = testGroup "Instructions" [ type' = i32, metadata = [] }, - "ptrtoint i32* %2 to i32"), + "ptrtoint ptr %2 to i32"), ("inttoptr", IntToPtr { operand0 = a 0, - type' = ptr i32, + type' = ptr, metadata = [] }, - "inttoptr i32 %0 to i32*"), + "inttoptr i32 %0 to ptr"), ("bitcast", BitCast { operand0 = a 0, @@ -446,10 +454,10 @@ tests = testGroup "Instructions" [ ("addrspacecast", AddrSpaceCast { operand0 = a 2, - type' = PointerType i32 (AddrSpace 2), + type' = PointerType (AddrSpace 2), metadata = [] }, - "addrspacecast i32* %2 to i32 addrspace(2)*"), + "addrspacecast ptr %2 to ptr addrspace(2)"), ("select", Select { condition' = a 4, @@ -464,7 +472,7 @@ tests = testGroup "Instructions" [ type' = i16, metadata = [] }, - "va_arg i32* %2, i16"), + "va_arg ptr %2, i16"), ("extractelement", ExtractElement { vector = a 5, @@ -507,21 +515,21 @@ tests = testGroup "Instructions" [ ("landingpad-" ++ n, LandingPad { type' = StructureType False [ - ptr i8, + ptr, i32 ], cleanup = cp, clauses = cls, metadata = [] }, - "landingpad { i8*, i32 }" <> s) + "landingpad { ptr, i32 }" <> s) | (clsn,cls,clss) <- [ ("catch", - [Catch (C.Null (ptr i8))], - "\n catch i8* null"), + [Catch (C.Null ptr)], + "\n catch ptr null"), ("filter", - [Filter (C.AggregateZero (ArrayType 1 (ptr i8)))], - "\n filter [1 x i8*] zeroinitializer") + [Filter (C.AggregateZero (ArrayType 1 ptr))], + "\n filter [1 x ptr] zeroinitializer") ], (cpn, cp, cps) <- [ ("-cleanup", True, "\n cleanup"), ("", False, "") ], let s = cps <> clss @@ -575,7 +583,7 @@ tests = testGroup "Instructions" [ alignment = 4, metadata = [] }, - "store i32 %0, i32* %2, align 4"), + "store i32 %0, ptr %2, align 4"), ("fence", Do $ Fence { atomicity = (System, Acquire), @@ -587,12 +595,13 @@ tests = testGroup "Instructions" [ tailCallKind = Nothing, callingConvention = CC.C, returnAttributes = [], - function = Right (ConstantOperand (C.GlobalReference (ptr (FunctionType A.T.void ts False)) (UnName 0))), + type' = FunctionType A.T.void ts False, + function = Right (ConstantOperand (C.GlobalReference (UnName 0))), arguments = [ (a i, []) | i <- [0..6] ], functionAttributes = [], metadata = [] }, - "call void @0(i32 %0, float %1, i32* %2, i64 %3, i1 %4, <2 x i32> %5, { i32, i32 } %6)") + "call void @0(i32 %0, float %1, ptr %2, i64 %3, i1 %4, <2 x i32> %5, { i32, i32 } %6)") ] ) ], @@ -611,13 +620,15 @@ tests = testGroup "Instructions" [ BasicBlock (UnName 1) [ UnName 2 := GetElementPtr { inBounds = True, - address = ConstantOperand (C.GlobalReference (ptr i32) (Name "fortytwo")), + type' = i32, + address = ConstantOperand (C.GlobalReference (Name "fortytwo")), indices = [ ConstantOperand (C.Int 32 0) ], metadata = [] }, UnName 3 := Load { volatile = False, - address = LocalReference (ptr i32) (UnName 2), + type' = i32, + address = LocalReference ptr (UnName 2), maybeAtomicity = Nothing, alignment = 1, metadata = [] @@ -634,8 +645,8 @@ tests = testGroup "Instructions" [ \@fortytwo = constant i32 42\n\ \\n\ \define i32 @0() {\n\ - \ %1 = getelementptr inbounds i32, i32* @fortytwo, i32 0\n\ - \ %2 = load i32, i32* %1, align 1\n\ + \ %1 = getelementptr inbounds i32, ptr @fortytwo, i32 0\n\ + \ %2 = load i32, ptr %1, align 1\n\ \ ret i32 %2\n\ \}\n" s <- withContext $ \context -> withModuleFromAST context mAST moduleLLVMAssembly @@ -758,7 +769,7 @@ tests = testGroup "Instructions" [ Module "" "" Nothing Nothing [ GlobalDefinition $ globalVariableDefaults { G.name = UnName 0, - G.type' = ptr i8, + G.type' = ptr, G.initializer = Just (C.BlockAddress (Name "foo") (UnName 2)) }, GlobalDefinition $ functionDefaults { @@ -768,14 +779,15 @@ tests = testGroup "Instructions" [ BasicBlock (UnName 0) [ UnName 1 := Load { volatile = False, - address = ConstantOperand (C.GlobalReference (ptr (ptr i8)) (UnName 0)), + type' = ptr, + address = ConstantOperand (C.GlobalReference (UnName 0)), maybeAtomicity = Nothing, alignment = 8, metadata = [] } ] ( Do $ IndirectBr { - operand0' = LocalReference (ptr i8) (UnName 1), + operand0' = LocalReference ptr (UnName 1), possibleDests = [UnName 2], metadata' = [] } @@ -789,11 +801,11 @@ tests = testGroup "Instructions" [ "; ModuleID = ''\n\ \source_filename = \"\"\n\ \\n\ - \@0 = global i8* blockaddress(@foo, %2)\n\ + \@0 = global ptr blockaddress(@foo, %2)\n\ \\n\ \define void @foo() {\n\ - \ %1 = load i8*, i8** @0, align 8\n\ - \ indirectbr i8* %1, [label %2]\n\ + \ %1 = load ptr, ptr @0, align 8\n\ + \ indirectbr ptr %1, [label %2]\n\ \\n\ \2: ; preds = %0\n\ \ ret void\n\ @@ -804,9 +816,7 @@ tests = testGroup "Instructions" [ GlobalDefinition $ functionDefaults { G.returnType = A.T.void, G.name = UnName 0, - G.personalityFunction = Just $ C.GlobalReference - (ptr (FunctionType A.T.void [i32,i16] False)) - (UnName 0) + G.personalityFunction = Just $ C.GlobalReference (UnName 0) , G.parameters = ([ Parameter i32 (UnName 0) [], @@ -817,7 +827,8 @@ tests = testGroup "Instructions" [ Do $ Invoke { callingConvention' = CC.C, returnAttributes' = [], - function' = Right (ConstantOperand (C.GlobalReference (ptr (FunctionType A.T.void [i32, i16] False)) (UnName 0))), + type'' = FunctionType A.T.void [i32, i16] False, + function' = Right (ConstantOperand (C.GlobalReference (UnName 0))), arguments' = [ (ConstantOperand (C.Int 32 4), []), (ConstantOperand (C.Int 16 8), []) @@ -834,11 +845,11 @@ tests = testGroup "Instructions" [ BasicBlock (Name "bar") [ UnName 3 := LandingPad { type' = StructureType False [ - ptr i8, + ptr, i32 ], cleanup = True, - clauses = [Catch (C.Null (ptr i8))], + clauses = [Catch (C.Null ptr)], metadata = [] } ] ( @@ -850,7 +861,7 @@ tests = testGroup "Instructions" [ "; ModuleID = ''\n\ \source_filename = \"\"\n\ \\n\ - \define void @0(i32 %0, i16 %1) personality void (i32, i16)* @0 {\n\ + \define void @0(i32 %0, i16 %1) personality ptr @0 {\n\ \ invoke void @0(i32 4, i16 8)\n\ \ to label %foo unwind label %bar\n\ \\n\ @@ -858,9 +869,9 @@ tests = testGroup "Instructions" [ \ ret void\n\ \\n\ \bar: ; preds = %2\n\ - \ %3 = landingpad { i8*, i32 }\n\ + \ %3 = landingpad { ptr, i32 }\n\ \ cleanup\n\ - \ catch i8* null\n\ + \ catch ptr null\n\ \ ret void\n\ \}\n" ), ( @@ -926,12 +937,10 @@ tests = testGroup "Instructions" [ Do Invoke { callingConvention' = CC.C, returnAttributes' = [], + type'' = FunctionType {resultType = VoidType, argumentTypes = [], isVarArg = False}, function' = Right ( ConstantOperand ( - C.GlobalReference PointerType { - pointerReferent = FunctionType {resultType = VoidType, argumentTypes = [], isVarArg = False}, - pointerAddrSpace = AddrSpace 0 - } (Name "_Z3quxv") + C.GlobalReference (Name "_Z3quxv") ) ), arguments' = [], @@ -954,10 +963,7 @@ tests = testGroup "Instructions" [ G.BasicBlock (Name "exit") [] (Do Ret { returnOperand = Nothing, metadata' = [] }) ], G.personalityFunction = Just ( - C.GlobalReference PointerType { - pointerReferent = FunctionType {resultType = IntegerType { typeBits = 32 }, argumentTypes = [], isVarArg = True}, - pointerAddrSpace = AddrSpace 0 - } (Name "__gxx_personality_v0") + C.GlobalReference (Name "__gxx_personality_v0") ) } ] @@ -969,7 +975,7 @@ tests = testGroup "Instructions" [ \\n\ \declare i32 @__gxx_personality_v0(...)\n\ \\n\ - \define void @cleanupret0() personality i32 (...)* @__gxx_personality_v0 {\n\ + \define void @cleanupret0() personality ptr @__gxx_personality_v0 {\n\ \entry:\n\ \ invoke void @_Z3quxv()\n\ \ to label %exit unwind label %pad\n\ @@ -1006,12 +1012,10 @@ tests = testGroup "Instructions" [ Do Invoke { callingConvention' = CC.C, returnAttributes' = [], + type'' = FunctionType {resultType = VoidType, argumentTypes = [], isVarArg = False}, function' = Right ( ConstantOperand ( - C.GlobalReference PointerType { - pointerReferent = FunctionType {resultType = VoidType, argumentTypes = [], isVarArg = False}, - pointerAddrSpace = AddrSpace 0 - } (Name "_Z3quxv") + C.GlobalReference (Name "_Z3quxv") ) ), arguments' = [], @@ -1036,10 +1040,7 @@ tests = testGroup "Instructions" [ G.BasicBlock (Name "exit") [] (Do Ret { returnOperand = Nothing, metadata' = [] }) ], G.personalityFunction = Just ( - C.GlobalReference PointerType { - pointerReferent = FunctionType {resultType = IntegerType { typeBits = 32 }, argumentTypes = [], isVarArg = True}, - pointerAddrSpace = AddrSpace 0 - } (Name "__gxx_personality_v0") + C.GlobalReference (Name "__gxx_personality_v0") ) } ] @@ -1051,7 +1052,7 @@ tests = testGroup "Instructions" [ \\n\ \declare i32 @__gxx_personality_v0(...)\n\ \\n\ - \define void @cleanupret1() personality i32 (...)* @__gxx_personality_v0 {\n\ + \define void @cleanupret1() personality ptr @__gxx_personality_v0 {\n\ \entry:\n\ \ invoke void @_Z3quxv()\n\ \ to label %exit unwind label %pad\n\ @@ -1091,12 +1092,10 @@ tests = testGroup "Instructions" [ Do Invoke { callingConvention' = CC.C, returnAttributes' = [], + type'' = FunctionType {resultType = VoidType, argumentTypes = [], isVarArg = False}, function' = Right ( ConstantOperand ( - C.GlobalReference PointerType { - pointerReferent = FunctionType {resultType = VoidType, argumentTypes = [], isVarArg = False}, - pointerAddrSpace = AddrSpace 0 - } (Name "_Z3quxv") + C.GlobalReference (Name "_Z3quxv") ) ), arguments' = [], @@ -1126,10 +1125,7 @@ tests = testGroup "Instructions" [ G.BasicBlock (Name "exit") [] (Do Ret { returnOperand = Nothing, metadata' = [] }) ], G.personalityFunction = Just ( - C.GlobalReference PointerType { - pointerReferent = FunctionType {resultType = IntegerType { typeBits = 32 }, argumentTypes = [], isVarArg = True}, - pointerAddrSpace = AddrSpace 0 - } (Name "__gxx_personality_v0") + C.GlobalReference (Name "__gxx_personality_v0") ) } ] @@ -1141,7 +1137,7 @@ tests = testGroup "Instructions" [ \\n\ \declare i32 @__gxx_personality_v0(...)\n\ \\n\ - \define void @catchret0() personality i32 (...)* @__gxx_personality_v0 {\n\ + \define void @catchret0() personality ptr @__gxx_personality_v0 {\n\ \entry:\n\ \ invoke void @_Z3quxv()\n\ \ to label %exit unwind label %pad\n\ @@ -1181,12 +1177,10 @@ tests = testGroup "Instructions" [ Do Invoke { callingConvention' = CC.C, returnAttributes' = [], + type'' = FunctionType {resultType = VoidType, argumentTypes = [], isVarArg = False}, function' = Right ( ConstantOperand ( - C.GlobalReference PointerType { - pointerReferent = FunctionType {resultType = VoidType, argumentTypes = [], isVarArg = False}, - pointerAddrSpace = AddrSpace 0 - } (Name "_Z3quxv") + C.GlobalReference (Name "_Z3quxv") ) ), arguments' = [], @@ -1219,10 +1213,7 @@ tests = testGroup "Instructions" [ G.BasicBlock (Name "exit") [] (Do Ret { returnOperand = Nothing, metadata' = [] }) ], G.personalityFunction = Just ( - C.GlobalReference PointerType { - pointerReferent = FunctionType {resultType = IntegerType { typeBits = 32 }, argumentTypes = [], isVarArg = True}, - pointerAddrSpace = AddrSpace 0 - } (Name "__gxx_personality_v0") + C.GlobalReference (Name "__gxx_personality_v0") ) } ] @@ -1234,7 +1225,7 @@ tests = testGroup "Instructions" [ \\n\ \declare i32 @__gxx_personality_v0(...)\n\ \\n\ - \define void @catchret0() personality i32 (...)* @__gxx_personality_v0 {\n\ + \define void @catchret0() personality ptr @__gxx_personality_v0 {\n\ \entry:\n\ \ invoke void @_Z3quxv()\n\ \ to label %exit unwind label %pad\n\ diff --git a/llvm-hs/test/LLVM/Test/Instrumentation.hs b/llvm-hs/test/LLVM/Test/Instrumentation.hs index 67f8c3d4..04341dbd 100644 --- a/llvm-hs/test/LLVM/Test/Instrumentation.hs +++ b/llvm-hs/test/LLVM/Test/Instrumentation.hs @@ -17,8 +17,7 @@ import qualified Data.Map as Map import LLVM.Module import LLVM.Context -import LLVM.PassManager -import LLVM.Transforms +import LLVM.Passes import LLVM.Target import LLVM.AST as A @@ -37,7 +36,7 @@ import qualified LLVM.AST.Constant as C instrument :: PassSetSpec -> A.Module -> IO A.Module instrument s m = withContext $ \context -> withModuleFromAST context m $ \mIn' -> do - withPassManager s $ \pm -> runPassManager pm mIn' + runPasses s mIn' moduleAST mIn' ast = do @@ -118,7 +117,7 @@ ast = do G.name = Name "main", G.parameters = ([ Parameter i32 (Name "argc") [], - Parameter (ptr (ptr i8)) (Name "argv") [] + Parameter ptr (Name "argv") [] ],False), G.basicBlocks = [ BasicBlock (UnName 0) [ @@ -126,12 +125,10 @@ ast = do tailCallKind = Nothing, callingConvention = CC.C, returnAttributes = [], + type' = FunctionType i32 [i128] False, function = Right (ConstantOperand (C.GlobalReference - (PointerType - { pointerReferent = FunctionType i32 [i128] False - , pointerAddrSpace = AddrSpace 0}) (Name "foo"))), arguments = [ (ConstantOperand (C.Int 128 9491828328), []) @@ -153,14 +150,15 @@ isMemorySanitizerSupported = do let os' = os triple' return $ Set.member os' (Set.fromList [FreeBSD, NetBSD, Linux]) -instrumentationPasses :: [(TestName, Pass, IO Bool)] +instrumentationPasses :: [(TestName, PassSetSpec, IO Bool)] instrumentationPasses = [ - ("GCOVProfiler", defaultGCOVProfiler, return True), - ("AddressSanitizer", defaultAddressSanitizer, return True), - ("AddressSanitizerModule", defaultAddressSanitizerModule, return True), - ("ThreadSanitizer", defaultThreadSanitizer, return True), - ("BoundsChecking", BoundsChecking, return True), - ("MemorySanitizer", defaultMemorySanitizer, isMemorySanitizerSupported) + -- TODO: Add back instrumentation passes + --("GCOVProfiler", defaultGCOVProfiler, return True), + --("AddressSanitizer", defaultAddressSanitizer, return True), + --("AddressSanitizerModule", defaultAddressSanitizerModule, return True), + --("ThreadSanitizer", defaultThreadSanitizer, return True), + --("BoundsChecking", BoundsChecking, return True), + --("MemorySanitizer", defaultMemorySanitizer, isMemorySanitizerSupported) ] tests = @@ -175,7 +173,7 @@ tests = withTargetLibraryInfo triple $ \tli -> do dl <- withHostTargetMachineDefault getTargetMachineDataLayout ast <- ast - ast' <- instrument (defaultPassSetSpec { transforms = [p], dataLayout = Just dl, targetLibraryInfo = Just tli }) ast + ast' <- instrument p ast let names ast = [ n | GlobalDefinition d <- moduleDefinitions ast, Name n <- return (G.name d) ] names ast' `List.intersect` names ast @?= names ast | diff --git a/llvm-hs/test/LLVM/Test/Linking.hs b/llvm-hs/test/LLVM/Test/Linking.hs index d3c23ecc..34a323f1 100644 --- a/llvm-hs/test/LLVM/Test/Linking.hs +++ b/llvm-hs/test/LLVM/Test/Linking.hs @@ -13,8 +13,6 @@ import qualified Data.Map as Map import LLVM.Module import LLVM.Context -import LLVM.PassManager -import LLVM.Transforms import LLVM.Target import LLVM.AST as A diff --git a/llvm-hs/test/LLVM/Test/Metadata.hs b/llvm-hs/test/LLVM/Test/Metadata.hs index b379ce74..692c4e85 100644 --- a/llvm-hs/test/LLVM/Test/Metadata.hs +++ b/llvm-hs/test/LLVM/Test/Metadata.hs @@ -827,7 +827,7 @@ cyclicMetadata = testGroup "cyclic" [ }, MetadataNodeDefinition (MetadataNodeID 0) - (MDTuple [Just $ MDValue $ ConstantOperand (C.GlobalReference (ptr (FunctionType A.T.void [] False)) (Name "foo"))]) + (MDTuple [Just $ MDValue $ ConstantOperand (C.GlobalReference (Name "foo"))]) ] let s = "; ModuleID = ''\n\ \source_filename = \"\"\n\ @@ -836,7 +836,7 @@ cyclicMetadata = testGroup "cyclic" [ \ ret void, !my-metadatum !0\n\ \}\n\ \\n\ - \!0 = !{void ()* @foo}\n" + \!0 = !{ptr @foo}\n" strCheck ast s ] diff --git a/llvm-hs/test/LLVM/Test/Module.hs b/llvm-hs/test/LLVM/Test/Module.hs index 3f0ef1eb..533f5916 100644 --- a/llvm-hs/test/LLVM/Test/Module.hs +++ b/llvm-hs/test/LLVM/Test/Module.hs @@ -42,8 +42,7 @@ import qualified LLVM.CodeGenOpt as CGO handString = "; ModuleID = ''\n\ \source_filename = \"\"\n\ \\n\ - \%0 = type { i32, %1*, %0* }\n\ - \%1 = type opaque\n\ + \%0 = type { i32, ptr, ptr }\n\ \\n\ \$bob = comdat largest\n\ \\n\ @@ -55,22 +54,22 @@ handString = "; ModuleID = ''\n\ \@.argyle = thread_local global i32 0\n\ \@5 = thread_local(localdynamic) global i32 1\n\ \\n\ - \@three = private alias i32, i32 addrspace(3)* @1\n\ - \@two = unnamed_addr alias i32, i32 addrspace(3)* @three\n\ - \@one = thread_local(initialexec) alias i32, i32* @5\n\ + \@three = private alias i32, ptr addrspace(3) @1\n\ + \@two = unnamed_addr alias i32, ptr addrspace(3) @three\n\ + \@one = thread_local(initialexec) alias i32, ptr @5\n\ \\n\ \define i32 @bar() prefix i32 1 {\n\ - \ %1 = musttail call zeroext i32 @foo(i32 inreg align 16 1, i8 signext 4) #0\n\ + \ %1 = musttail call zeroext i32 @foo(i32 inreg 1, i8 signext 4) #0\n\ \ ret i32 %1\n\ \}\n\ \\n\ \define i32 @baz() prefix i32 1 {\n\ - \ %1 = notail call zeroext i32 @foo(i32 inreg align 16 1, i8 signext 4) #0\n\ + \ %1 = notail call zeroext i32 @foo(i32 inreg 1, i8 signext 4) #0\n\ \ ret i32 %1\n\ \}\n\ \\n\ \; Function Attrs: nounwind readnone uwtable\n\ - \define zeroext i32 @foo(i32 inreg align 16 %x, i8 signext %y) #0 {\n\ + \define zeroext i32 @foo(i32 inreg %x, i8 signext %y) #0 {\n\ \ %1 = mul nsw i32 %x, %x\n\ \ br label %here\n\ \\n\ @@ -93,10 +92,9 @@ handAST = Module "" "" Nothing Nothing [ TypeDefinition (UnName 0) ( Just $ StructureType False [ i32, - ptr (NamedTypeReference (UnName 1)), - ptr (NamedTypeReference (UnName 0)) + ptr, + ptr ]), - TypeDefinition (UnName 1) Nothing, GlobalDefinition $ globalVariableDefaults { G.name = UnName 0, G.type' = i32, @@ -142,19 +140,19 @@ handAST = Module "" "" Nothing Nothing [ G.linkage = L.Private, G.type' = i32, G.addrSpace = AddrSpace 3, - G.aliasee = C.GlobalReference (PointerType i32 (AddrSpace 3)) (UnName 1) + G.aliasee = C.GlobalReference (UnName 1) }, GlobalDefinition $ globalAliasDefaults { G.name = Name "two", G.unnamedAddr = Just GlobalAddr, G.type' = i32, G.addrSpace = AddrSpace 3, - G.aliasee = C.GlobalReference (PointerType i32 (AddrSpace 3)) (Name "three") + G.aliasee = C.GlobalReference (Name "three") }, GlobalDefinition $ globalAliasDefaults { G.name = Name "one", G.type' = i32, - G.aliasee = C.GlobalReference (ptr i32) (UnName 5), + G.aliasee = C.GlobalReference (UnName 5), G.threadLocalMode = Just TLS.InitialExec }, GlobalDefinition $ functionDefaults { @@ -167,9 +165,10 @@ handAST = Module "" "" Nothing Nothing [ tailCallKind = Just MustTail, callingConvention = CC.C, returnAttributes = [PA.ZeroExt], - function = Right (ConstantOperand (C.GlobalReference (ptr (FunctionType i32 [i32, i8] False)) (Name "foo"))), + type' = FunctionType i32 [i32, i8] False, + function = Right (ConstantOperand (C.GlobalReference (Name "foo"))), arguments = [ - (ConstantOperand (C.Int 32 1), [PA.InReg, PA.Alignment 16]), + (ConstantOperand (C.Int 32 1), [PA.InReg]), (ConstantOperand (C.Int 8 4), [PA.SignExt]) ], functionAttributes = [Left (FA.GroupID 0)], @@ -190,9 +189,10 @@ handAST = Module "" "" Nothing Nothing [ tailCallKind = Just NoTail, callingConvention = CC.C, returnAttributes = [PA.ZeroExt], - function = Right (ConstantOperand (C.GlobalReference (ptr (FunctionType i32 [i32, i8] False)) (Name "foo"))), + type' = FunctionType i32 [i32, i8] False, + function = Right (ConstantOperand (C.GlobalReference (Name "foo"))), arguments = [ - (ConstantOperand (C.Int 32 1), [PA.InReg, PA.Alignment 16]), + (ConstantOperand (C.Int 32 1), [PA.InReg]), (ConstantOperand (C.Int 8 4), [PA.SignExt]) ], functionAttributes = [Left (FA.GroupID 0)], @@ -208,7 +208,7 @@ handAST = Module "" "" Nothing Nothing [ G.returnType = i32, G.name = Name "foo", G.parameters = ([ - Parameter i32 (Name "x") [PA.InReg, PA.Alignment 16], + Parameter i32 (Name "x") [PA.InReg], Parameter i8 (Name "y") [PA.SignExt] ], False), G.functionAttributes = [Left (FA.GroupID 0)], @@ -286,7 +286,7 @@ tests = testGroup "Module" [ testGroup "emit" [ testCase "assemble" $ withContext $ \context -> do - let s = "define i32 @main(i32 %argc, i8** %argv) {\n\ + let s = "define i32 @main(i32 %argc, ptr %argv) {\n\ \ ret i32 0\n\ \}\n" a <- withModuleFromLLVMAssembly' context s $ \m -> do @@ -317,7 +317,7 @@ tests = testGroup "Module" [ testCase "moduleAST" $ withContext $ \context -> do ast <- withModuleFromLLVMAssembly' context handString moduleAST assertEqPretty ast handAST, - + testCase "withModuleFromAST" $ withContext $ \context -> do s <- withModuleFromAST context handAST moduleLLVMAssembly s @?= handString, @@ -457,7 +457,7 @@ tests = testGroup "Module" [ ] ( Do $ Br (Name "elsewhere") [] ), - BasicBlock (Name "elsewhere") [ + BasicBlock (Name "elsewhere") [ ] ( Do $ Br (Name "there") [] ), @@ -536,7 +536,7 @@ tests = testGroup "Module" [ ] strCheck ast s ], - + testGroup "failures" [ testCase "bad block reference" $ withContext $ \context -> do let badAST = Module "" "" Nothing Nothing [ @@ -610,8 +610,8 @@ tests = testGroup "Module" [ t @?= Left (EncodeException "A type definition requires a structure type but got: VoidType"), testCase "renamed type definitions" $ do let modStr1 = unlines - [ "%struct = type { %struct* }" - , "define void @f(%struct*) {" + [ "%struct = type { ptr }" + , "define void @f(ptr) {" , " ret void" , "}" ] @@ -619,10 +619,10 @@ tests = testGroup "Module" [ [ ] modStr2 = unlines - [ "%struct = type { %struct* }" - , "declare void @f(%struct*)" + [ "%struct = type { ptr }" + , "declare void @f(ptr)" , "define void @main() {" - , " call void @f(%struct* zeroinitializer)" + , " call void @f(ptr zeroinitializer)" , " ret void" , "}" ] diff --git a/llvm-hs/test/LLVM/Test/Optimization.hs b/llvm-hs/test/LLVM/Test/Optimization.hs index 004f38b5..27586b68 100644 --- a/llvm-hs/test/LLVM/Test/Optimization.hs +++ b/llvm-hs/test/LLVM/Test/Optimization.hs @@ -14,8 +14,7 @@ import qualified Data.Map as Map import LLVM.Module import LLVM.Context -import LLVM.PassManager -import qualified LLVM.Transforms as T +import LLVM.Passes import LLVM.Target import LLVM.AST as A @@ -99,36 +98,14 @@ handAST = FunctionAttributes (A.GroupID 0) [A.NoUnwind, A.ReadNone, A.UWTable] ] -pattern LLVMLoopIsVectorizedMetadata :: Integer -> Definition -pattern LLVMLoopIsVectorizedMetadata i <- MetadataNodeDefinition _ (MDTuple [ - Just (MDString "llvm.loop.isvectorized"), - Just (MDValue (ConstantOperand C.Int {C.integerBits = 32, C.integerValue = i})) - ]) - -isVectorized :: A.Module -> Assertion -isVectorized mod@Module { moduleDefinitions = defs } = do - let assertHasVectorTypedValues = - (@? "Module contains no vector-typed phi instructions") $ - not $ null [ i - | GlobalDefinition Function { G.basicBlocks = b } <- defs, - BasicBlock _ is _ <- b, - _ := i@Phi { type' = VectorType _ _ } <- is - ] - let assertHasVectorizedMetadata = - (@? "Module is missing 'llvm.loop.isvectorized' metadata") $ - not $ null [ 1 - | LLVMLoopIsVectorizedMetadata 1 <- defs - ] - assertHasVectorTypedValues <> assertHasVectorizedMetadata - optimize :: PassSetSpec -> A.Module -> IO A.Module optimize pss m = withContext $ \context -> withModuleFromAST context m $ \mIn' -> do - withPassManager pss $ \pm -> runPassManager pm mIn' + runPasses pss mIn' moduleAST mIn' tests = testGroup "Optimization" [ testCase "curated" $ do - mOut <- optimize defaultCuratedPassSetSpec handAST + mOut <- optimize (PassSetSpec [CuratedPassSet 2] Nothing) handAST mOut @?= Module "" "" Nothing Nothing [ GlobalDefinition $ functionDefaults { @@ -143,202 +120,6 @@ tests = testGroup "Optimization" [ ) ] }, - FunctionAttributes (A.GroupID 0) [A.NoRecurse, A.NoUnwind, A.ReadNone, A.UWTable, A.WillReturn] - ], - - testGroup "individual" [ - testCase "InstSimplify" $ do - let - mIn = Module "" "" Nothing Nothing [ - GlobalDefinition $ functionDefaults { - G.returnType = i32, - G.name = Name "foo", - G.parameters = ([Parameter i32 (Name "x") []], False), - G.functionAttributes = [Left (A.GroupID 0)], - G.basicBlocks = [ - BasicBlock (UnName 0) [] (Do $ Br (Name "here") []), - BasicBlock (Name "here") [] ( - Do $ CondBr { - condition = ConstantOperand (C.Int 1 1), - trueDest = Name "take", - falseDest = Name "done", - metadata' = [] - } - ), - BasicBlock (Name "take") [] ( - Do $ Br (Name "done") [] - ), - BasicBlock (Name "done") [ - Name "r" := Phi { - type' = i32, - incomingValues = [(ConstantOperand (C.Int 32 0), Name "take"), (ConstantOperand (C.Int 32 57), Name "here")], - metadata = [] - } - ] ( - Do $ Ret (Just (LocalReference i32 (Name "r"))) [] - ) - ] - }, - FunctionAttributes (A.GroupID 0) [A.NoUnwind, A.ReadNone, A.UWTable] - ] - mOut <- optimize defaultPassSetSpec { transforms = [T.InstructionSimplify] } handAST - mOut @?= mIn, - - 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 = doubleVec, - G.name = Name "buildVector_add_2f64", - G.parameters = ([ - Parameter doubleVec n [] - | n <- [ "a", "b" ] - ], False), - G.basicBlocks = [ - 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.SuperwordLevelParallelismVectorize, - T.InstructionCombining, - T.GlobalValueNumbering False - ] }) mIn - 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 = - Module { - moduleName = "", - moduleSourceFileName = "", - moduleDataLayout = Just $ (defaultDataLayout BigEndian) { - typeLayouts = Map.singleton (VectorAlign, 128) (AlignmentInfo 128 128) - }, - moduleTargetTriple = Just "x86_64", - moduleDefinitions = [ - GlobalDefinition $ globalVariableDefaults { - G.name = Name "a", - G.linkage = L.Common, - G.type' = A.T.ArrayType 2048 i32, - G.initializer = Just (C.AggregateZero (A.T.ArrayType 2048 i32)) - }, - GlobalDefinition $ functionDefaults { - G.returnType = A.T.void, - G.name = Name "inc", - G.functionAttributes = [Left (A.GroupID 0)], - G.parameters = ([Parameter i32 (Name "n") []], False), - G.basicBlocks = [ - BasicBlock (UnName 0) [ - UnName 1 := ICmp IPred.SGT (LocalReference i32 (Name "n")) (ConstantOperand (C.Int 32 0)) [] - ] (Do $ CondBr (LocalReference i1 (UnName 1)) (Name ".lr.ph") (Name "._crit_edge") []), - BasicBlock (Name ".lr.ph") [ - Name "indvars.iv" := Phi i64 [ - (ConstantOperand (C.Int 64 0), UnName 0), - (LocalReference i64 (Name "indvars.iv.next"), Name ".lr.ph") - ] [], - 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") - ] [], - UnName 3 := Load False (LocalReference (ptr i32) (UnName 2)) Nothing 4 [], - UnName 4 := Trunc (LocalReference i64 (Name "indvars.iv")) i32 [], - UnName 5 := Add True False (LocalReference i32 (UnName 3)) (LocalReference i32 (UnName 4)) [], - Do $ Store False (LocalReference (ptr i32) (UnName 2)) (LocalReference i32 (UnName 5)) Nothing 4 [], - Name "indvars.iv.next" := Add False False (LocalReference i64 (Name "indvars.iv")) (ConstantOperand (C.Int 64 1)) [], - Name "lftr.wideiv" := Trunc (LocalReference i64 (Name "indvars.iv.next")) i32 [], - Name "exitcond" := ICmp IPred.EQ (LocalReference i32 (Name "lftr.wideiv")) (LocalReference i32 (Name "n")) [] - ] (Do $ CondBr (LocalReference i1 (Name "exitcond")) (Name "._crit_edge") (Name ".lr.ph") []), - BasicBlock (Name "._crit_edge") [ - ] (Do $ Ret Nothing []) - ] - }, - FunctionAttributes (A.GroupID 0) [A.NoUnwind, A.ReadNone, A.UWTable, A.StackProtect] - ] - } - mOut <- do - initializeAllTargets - let triple = "x86_64" - (target, _) <- lookupTarget Nothing triple - withTargetOptions $ \targetOptions -> do - withTargetMachine target triple "" Map.empty targetOptions R.Default CM.Default CGO.Default $ \tm -> do - optimize (defaultPassSetSpec { - transforms = [ T.defaultLoopVectorize ], - dataLayout = moduleDataLayout mIn, - targetMachine = Just tm - }) mIn - isVectorized mOut, - - testCase "LowerInvoke" $ do - -- This test doesn't test much about what LowerInvoke does, just that it seems to work. - -- The pass seems to be quite deeply dependent on weakly documented presumptions about - -- how unwinding works (as is the invoke instruction) - withContext $ \context -> do - withPassManager (defaultPassSetSpec { transforms = [T.LowerInvoke] }) $ \passManager -> do - let astIn = - Module "" "" Nothing Nothing [ - GlobalDefinition $ functionDefaults { - G.returnType = i32, - G.name = Name "foo", - G.parameters = ([Parameter i32 (Name "x") []], False), - G.basicBlocks = [ - BasicBlock (Name "here") [ - ] ( - Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [] - ) - ] - } - ] - astOut <- withModuleFromAST context astIn $ \mIn -> do - runPassManager passManager mIn - moduleAST mIn - astOut @?= Module "" "" Nothing Nothing [ - GlobalDefinition $ functionDefaults { - G.returnType = i32, - G.name = Name "foo", - G.parameters = ([Parameter i32 (Name "x") []], False), - G.basicBlocks = [ - BasicBlock (Name "here") [ - ] ( - Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [] - ) - ] - } - ] - ] + FunctionAttributes (A.GroupID 0) [A.MustProgress, A.NoFree, A.NoRecurse, A.NoSync, A.NoUnwind, A.ReadNone, A.WillReturn, A.UWTable] + ] ] diff --git a/llvm-hs/test/LLVM/Test/OrcJIT.hs b/llvm-hs/test/LLVM/Test/OrcJIT.hs index 1361140b..cf8e9d6b 100644 --- a/llvm-hs/test/LLVM/Test/OrcJIT.hs +++ b/llvm-hs/test/LLVM/Test/OrcJIT.hs @@ -18,13 +18,14 @@ import Foreign.Storable import Foreign.Marshal.Alloc import System.Process (callProcess) import System.IO.Temp (withSystemTempFile) +import System.Directory import System.IO -import LLVM.Internal.PassManager import LLVM.Internal.ObjectFile (withObjectFile) -import LLVM.PassManager +import LLVM.Passes import LLVM.Context import LLVM.Module +import qualified LLVM.Internal.FFI.Module as FFI import LLVM.OrcJIT import LLVM.Target import qualified LLVM.Relocation as Reloc @@ -77,7 +78,7 @@ foreign import ccall "dynamic" tests :: TestTree tests = testGroup "OrcJIT" [ - testCase "basic self-contained function" $ do + testCase "basic self-contained function" $ withHostTargetMachine Reloc.PIC CodeModel.Default CodeGenOpt.Default $ \tm -> withExecutionSession $ \es -> do ol <- createRTDyldObjectLinkingLayer es @@ -113,29 +114,29 @@ tests = dylib <- createJITDylib es "testDylib" let inputPath = "./test/main_return_38.c" withSystemTempFile "main.o" $ \outputPath _ -> do - callProcess "gcc" ["-shared", "-fPIC", inputPath, "-o", outputPath] - addDynamicLibrarySearchGenerator il dylib outputPath - Right (JITSymbol mainFn _) <- lookupSymbol es il dylib "main" - result <- mkMain (castPtrToFunPtr (wordPtrToPtr mainFn)) - result @?= 38, + findExecutable "gcc" >>= \gccPath -> + case gccPath of + Nothing -> return () -- Tasty.HUnit doesn't seem to support skips? + Just _ -> do + callProcess "gcc" ["-shared", "-fPIC", inputPath, "-o", outputPath] + addDynamicLibrarySearchGenerator il dylib outputPath + Right (JITSymbol mainFn _) <- lookupSymbol es il dylib "main" + result <- mkMain (castPtrToFunPtr (wordPtrToPtr mainFn)) + result @?= 38, testCase "run optimization passes on a JIT module" $ do - passmanagerSuccessful <- newIORef False withHostTargetMachine Reloc.PIC CodeModel.Default CodeGenOpt.Default $ \tm -> withExecutionSession $ \es -> do ol <- createRTDyldObjectLinkingLayer es il <- createIRCompileLayer es ol tm dylib <- createJITDylib es "testDylib" withTestModule test2Module $ \m -> do - withPassManager defaultCuratedPassSetSpec { optLevel = Just 2 } $ \pm -> do - success <- runPassManager pm m - writeIORef passmanagerSuccessful success - withClonedThreadSafeModule m $ \tsm -> do - addModule tsm dylib il - Right (JITSymbol mainFn _) <- lookupSymbol es il dylib "main" - result <- mkMain (castPtrToFunPtr (wordPtrToPtr mainFn)) - result @?= 42 - readIORef passmanagerSuccessful @? "passmanager failed", + runPasses (PassSetSpec [CuratedPassSet 2] Nothing) m + withClonedThreadSafeModule m $ \tsm -> do + addModule tsm dylib il + Right (JITSymbol mainFn _) <- lookupSymbol es il dylib "main" + result <- mkMain (castPtrToFunPtr (wordPtrToPtr mainFn)) + result @?= 42, testCase "defining absolute symbols" $ do withHostTargetMachine Reloc.PIC CodeModel.Default CodeGenOpt.Default $ \tm -> @@ -208,4 +209,25 @@ tests = result @?= 42, -} + -- TODO: Add support for loading object files and update to OrcJITv2 + {- + testCase "finding symbols in linking layer" $ + withExecutionSession $ \es -> + withModuleKey es $ \k -> + withSymbolResolver es (SymbolResolver nullResolver) $ \resolver -> + withObjectLinkingLayer es (\_ -> pure resolver) $ \linkingLayer -> do + let inputPath = "./test/main_return_38.c" + withSystemTempFile "main.o" $ \outputPath _ -> do + callProcess "gcc" ["-c", inputPath, "-o", outputPath] + withObjectFile outputPath $ \objFile -> do + addObjectFile linkingLayer k objFile + -- Find main symbol by looking into global linking context + Right (JITSymbol mainFn _) <- LL.findSymbol linkingLayer "main" True + result <- mkMain (castPtrToFunPtr (wordPtrToPtr mainFn)) + result @?= 38 + -- Find main symbol by specificly using object handle for given object file + Right (JITSymbol mainFn _) <- LL.findSymbolIn linkingLayer k "main" True + result <- mkMain (castPtrToFunPtr (wordPtrToPtr mainFn)) + result @?= 38, + -} ] diff --git a/llvm-hs/test/LLVM/Test/ParameterAttribute.hs b/llvm-hs/test/LLVM/Test/ParameterAttribute.hs index af7cf4ad..9e0b1639 100644 --- a/llvm-hs/test/LLVM/Test/ParameterAttribute.hs +++ b/llvm-hs/test/LLVM/Test/ParameterAttribute.hs @@ -9,6 +9,7 @@ import Test.Tasty.QuickCheck hiding ( (.&.) ) import LLVM.Test.Support import LLVM.AST.ParameterAttribute +import qualified LLVM.AST as A import LLVM.Internal.Coding import LLVM.Internal.Context import LLVM.Internal.EncodeAST @@ -30,10 +31,11 @@ instance Arbitrary ParameterAttribute where [ return ZeroExt , return SignExt , return InReg - , return SRet - , Alignment <$> elements (map (2^) [0..30 :: Int]) + , return $ SRet $ A.IntegerType 32 + -- LLVM doesn't allow alignments larger than 2^29! + , Alignment <$> elements (map (2^) [0..29 :: Int]) , return NoAlias - , return ByVal + , return $ ByVal $ A.IntegerType 32 , return NoCapture , return NoFree , return Nest @@ -41,7 +43,7 @@ instance Arbitrary ParameterAttribute where , return ReadOnly , return WriteOnly , return ImmArg - , return InAlloca + , return $ InAlloca $ A.IntegerType 32 , return NonNull , Dereferenceable <$> suchThat arbitrary (/= 0) , DereferenceableOrNull <$> suchThat arbitrary (/= 0) diff --git a/llvm-hs/test/LLVM/Test/Regression.hs b/llvm-hs/test/LLVM/Test/Regression.hs index 743f475c..30785f53 100644 --- a/llvm-hs/test/LLVM/Test/Regression.hs +++ b/llvm-hs/test/LLVM/Test/Regression.hs @@ -35,7 +35,7 @@ example1 = , UnName 1 := Store False - (LocalReference (ptr i32) (UnName 0)) + (LocalReference ptr (UnName 0)) (ConstantOperand (C.Int 32 42)) Nothing 0 @@ -47,61 +47,6 @@ example1 = ] } -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 $ - C.GlobalReference (FunctionType void [] False) "test") - Nothing - 0 - [] - ] - (Do $ Ret Nothing []) - ] - } - ] - } - -example3 :: AST.Module -example3 = - defaultModule - { moduleDefinitions = - [ GlobalDefinition - functionDefaults - { name = "test" - , returnType = void - , basicBlocks = - [ BasicBlock - "entry" - [ UnName 0 := GetElementPtr { - inBounds = False, - address = ConstantOperand (C.Null i32), - indices = [ ConstantOperand (C.Int 32 0) ], - metadata = [] - } - ] - (Do $ Ret Nothing []) - ] - } - ] - } - duplicateDefinitions :: AST.Module duplicateDefinitions = defaultModule @@ -202,15 +147,7 @@ tests = [ 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 Name \"test\" has type FunctionType {resultType = VoidType, argumentTypes = [], isVarArg = False} but should have type PointerType {pointerReferent = FunctionType {resultType = VoidType, argumentTypes = [], isVarArg = False}, pointerAddrSpace = AddrSpace 0}") - , testCase - "null constants must have pointer type" - (example3 `shouldThrowEncodeException` - "Null pointer constant must have pointer type but has type IntegerType {typeBits = 32}.") + "Instruction of type void must not have a name: UnName 1 := Store {volatile = False, address = LocalReference (PointerType {pointerAddrSpace = AddrSpace 0}) (UnName 0), value = ConstantOperand (Int {integerBits = 32, integerValue = 42}), maybeAtomicity = Nothing, alignment = 0, metadata = []}") , testCase "Duplicate definitions are not allowed" (duplicateDefinitions `shouldThrowEncodeException` diff --git a/llvm-hs/test/LLVM/Test/Support.hs b/llvm-hs/test/LLVM/Test/Support.hs index 0bae50cc..08452b61 100644 --- a/llvm-hs/test/LLVM/Test/Support.hs +++ b/llvm-hs/test/LLVM/Test/Support.hs @@ -20,6 +20,7 @@ import Text.Show.Pretty import LLVM.Context import LLVM.Module import LLVM.Diagnostic +import LLVM.Target withModuleFromLLVMAssembly' :: Context -> ByteString -> (Module -> IO a) -> IO a withModuleFromLLVMAssembly' c s f = withModuleFromLLVMAssembly c s f @@ -40,3 +41,6 @@ strCheck mAST mStr = strCheckC mAST mStr mStr arbitrarySbs :: Gen ShortByteString arbitrarySbs = BSS.pack <$> listOf arbitrary + +withTargets :: TestTree -> TestTree +withTargets = withResource initializeAllTargets return . const diff --git a/llvm-hs/test/LLVM/Test/Target.hs b/llvm-hs/test/LLVM/Test/Target.hs index 0843b80f..e9aa4450 100644 --- a/llvm-hs/test/LLVM/Test/Target.hs +++ b/llvm-hs/test/LLVM/Test/Target.hs @@ -74,7 +74,6 @@ instance Arbitrary Options where trapUnreachable <- arbitrary emulatedThreadLocalStorage <- arbitrary enableInterProceduralRegisterAllocation <- arbitrary - stackAlignmentOverride <- arbitrary floatABIType <- arbitrary allowFloatingPointOperationFusion <- arbitrary threadModel <- arbitrary @@ -85,6 +84,9 @@ instance Arbitrary Options where machineCodeOptions <- arbitrary return Options { .. } +instance Arbitrary DwarfDirectory where + arbitrary = elements [minBound .. maxBound] + instance Arbitrary MachineCodeOptions where arbitrary = do relaxAll <- arbitrary @@ -102,7 +104,7 @@ instance Arbitrary MachineCodeOptions where return MachineCodeOptions { .. } instance Arbitrary DebugCompressionType where - arbitrary = elements [CompressNone, CompressGNU, CompressZ] + arbitrary = elements [CompressNone, CompressZlib] arbitraryASCIIString :: Gen String #if MIN_VERSION_QuickCheck(2,10,0) @@ -131,6 +133,7 @@ tests = testGroup "Target" [ reloc = Reloc.Default codeModel = CodeModel.Default codeGenOpt = CodeGenOpt.Default + initializeAllTargets (target, _) <- lookupTarget Nothing triple withTargetMachine target triple cpu features to reloc codeModel codeGenOpt $ \tm -> do options' <- peekTargetOptions =<< targetMachineOptions tm diff --git a/llvm-hs/test/LLVM/Test/Tests.hs b/llvm-hs/test/LLVM/Test/Tests.hs index 1dccd2da..127fc9ac 100644 --- a/llvm-hs/test/LLVM/Test/Tests.hs +++ b/llvm-hs/test/LLVM/Test/Tests.hs @@ -22,8 +22,10 @@ import qualified LLVM.Test.OrcJIT as OrcJIT import qualified LLVM.Test.ParameterAttribute as ParameterAttribute import qualified LLVM.Test.Target as Target import qualified LLVM.Test.Regression as Regression +import qualified LLVM.Test.Support as Support -tests = testGroup "llvm-hs" [ + +tests = Support.withTargets $ testGroup "llvm-hs" [ CallingConvention.tests, Constants.tests, DataLayout.tests, diff --git a/stack.yaml b/stack.yaml index 54d2023d..623eccbb 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,7 +6,3 @@ resolver: nightly-2021-07-04 # 9.0.1 packages: - llvm-hs - llvm-hs-pure - -# We should not need to do this, but unfortunately, removing it breaks the stack build. -ghc-options: - llvm-hs: -optcxx=-std=c++14 -optcxx=-lstdc++ -optcxx=-fno-rtti pFad - Phonifier reborn

Pfad - The Proxy pFad of © 2024 Garber Painting. All rights reserved.

Note: This service is not intended for secure transactions such as banking, social media, email, or purchasing. Use at your own risk. We assume no liability whatsoever for broken pages.


Alternative Proxies:

Alternative Proxy

pFad Proxy

pFad v3 Proxy

pFad v4 Proxy