diff --git a/llvm-hs-pure/CHANGELOG.md b/llvm-hs-pure/CHANGELOG.md index fe151d28..c0abd1fa 100644 --- a/llvm-hs-pure/CHANGELOG.md +++ b/llvm-hs-pure/CHANGELOG.md @@ -1,3 +1,14 @@ +## 9.1.0 (2021-10-XX) + +* Eliminate hard-coded assumption of 32-bit `size_t` +* Add a runtime variant of the `LLVM.AST.Constant.sizeof` utility in `LLVM.IRBuilder.Instruction.sizeof`. The size of opaque structure types is unknown until link-time and therefore cannot be computed as a constant. +* Handle type resolution through `NamedTypeReference` correctly: type resolution in LLVM depends on module state by design +* Support the LLVM `NoFree` attribute +* Add support for some more DWARF operators: `DW_OP_bregx` and `DW_OP_push_object_address` +* IRBuilder: first emitted terminator (`br`, `condBr`, `ret`, ...) is only + generated in final IR. This allows for greater composition of IR (and matches + with LLVM semantics, since later instructions are unreachable). + ## 9.0.0 (2019-09-06) * The functions in `LLVM.IRBuilder.Constant` no longer return a diff --git a/llvm-hs-pure/llvm-hs-pure.cabal b/llvm-hs-pure/llvm-hs-pure.cabal index 656632b7..414b9875 100644 --- a/llvm-hs-pure/llvm-hs-pure.cabal +++ b/llvm-hs-pure/llvm-hs-pure.cabal @@ -1,9 +1,9 @@ name: llvm-hs-pure -version: 9.0.0 +version: 9.0.1.1 license: BSD3 license-file: LICENSE -author: Anthony Cowley, Stephen Diehl, Moritz Kiefer , Benjamin S. Scarlet -maintainer: Anthony Cowley, Stephen Diehl, Moritz Kiefer +author: Anthony Cowley, Stephen Diehl, Moritz Kiefer , Andrew Anderson , Benjamin S. Scarlet +maintainer: Anthony Cowley, Stephen Diehl, Moritz Kiefer , Andrew Anderson copyright: (c) 2013 Benjamin S. Scarlet and Google Inc. homepage: http://github.com/llvm-hs/llvm-hs/ bug-reports: http://github.com/llvm-hs/llvm-hs/issues @@ -16,7 +16,7 @@ description: llvm-hs-pure is a set of pure Haskell types and functions for interacting with LLVM . It includes an ADT to represent LLVM IR (). The llvm-hs package builds on this one with FFI bindings to LLVM, but llvm-hs-pure does not require LLVM to be available. -tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5 +tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.10.4 extra-source-files: CHANGELOG.md source-repository head diff --git a/llvm-hs-pure/src/LLVM/AST/Operand.hs b/llvm-hs-pure/src/LLVM/AST/Operand.hs index 47d366fd..ab05803f 100644 --- a/llvm-hs-pure/src/LLVM/AST/Operand.hs +++ b/llvm-hs-pure/src/LLVM/AST/Operand.hs @@ -61,27 +61,29 @@ data DWOpFragment = DW_OP_LLVM_Fragment -- | data DWOp - = DwOpFragment DWOpFragment -- ^ Must appear at the end - | DW_OP_StackValue -- ^ Must be the last one or followed by a DW_OP_LLVM_Fragment - | DW_OP_Swap + = DW_OP_And + | DW_OP_Bregx | DW_OP_ConstU Word64 + | DW_OP_Deref + | DW_OP_Div + | DW_OP_Dup + | DwOpFragment DWOpFragment -- ^ Must appear at the end | DW_OP_Lit0 - | DW_OP_PlusUConst Word64 - | DW_OP_Plus | DW_OP_Minus - | DW_OP_Mul - | DW_OP_Div | DW_OP_Mod + | DW_OP_Mul | DW_OP_Not | DW_OP_Or - | DW_OP_Xor - | DW_OP_And + | DW_OP_Plus + | DW_OP_PlusUConst Word64 + | DW_OP_PushObjectAddress + | DW_OP_Shl | DW_OP_Shr | DW_OP_Shra - | DW_OP_Shl - | DW_OP_Dup - | DW_OP_Deref + | DW_OP_StackValue -- ^ Must be the last one or followed by a DW_OP_LLVM_Fragment + | DW_OP_Swap | DW_OP_XDeref + | DW_OP_Xor deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- | diff --git a/llvm-hs-pure/src/LLVM/AST/Typed.hs b/llvm-hs-pure/src/LLVM/AST/Typed.hs index 238a445e..0cd9f72d 100644 --- a/llvm-hs-pure/src/LLVM/AST/Typed.hs +++ b/llvm-hs-pure/src/LLVM/AST/Typed.hs @@ -4,49 +4,65 @@ module LLVM.AST.Typed ( Typed(..), getElementType, - getElementPtrType, + indexTypeByConstants, + indexTypeByOperands, extractValueType, ) where import LLVM.Prelude +import Control.Monad.State (gets) +import qualified Data.Map.Lazy as Map +import qualified Data.Either as Either import GHC.Stack import LLVM.AST import LLVM.AST.Global import LLVM.AST.Type +import LLVM.IRBuilder.Module + import qualified LLVM.AST.Constant as C import qualified LLVM.AST.Float as F class Typed a where - typeOf :: HasCallStack => a -> Type + typeOf :: (HasCallStack, MonadModuleBuilder m) => a -> m (Either String Type) instance Typed Operand where - typeOf (LocalReference t _) = t + typeOf (LocalReference t _) = return $ Right t typeOf (ConstantOperand c) = typeOf c - typeOf _ = MetadataType + typeOf _ = return $ Right MetadataType instance Typed CallableOperand where typeOf (Right op) = typeOf op - typeOf (Left _) = error "typeOf inline assembler is not defined. (Malformed AST)" + typeOf (Left _) = return $ Left "typeOf inline assembler is not defined. (Malformed AST)" instance Typed C.Constant where - typeOf (C.Int bits _) = IntegerType bits - typeOf (C.Float t) = typeOf t - typeOf (C.Null t) = t - typeOf (C.AggregateZero t) = t + typeOf (C.Int bits _) = return $ Right $ IntegerType bits + typeOf (C.Float t) = typeOf t + typeOf (C.Null t) = return $ Right t + typeOf (C.AggregateZero t) = return $ Right t typeOf (C.Struct {..}) = case structName of - Nothing -> StructureType isPacked (map typeOf memberValues) - Just sn -> NamedTypeReference sn - typeOf (C.Array {..}) = ArrayType (fromIntegral $ length memberValues) memberType - typeOf (C.Vector {..}) = VectorType (fromIntegral $ length memberValues) $ - case memberValues of - [] -> error "Vectors of size zero are not allowed. (Malformed AST)" - (x:_) -> typeOf x - typeOf (C.Undef t) = t - typeOf (C.BlockAddress {..}) = ptr i8 - typeOf (C.GlobalReference t _) = t + Nothing -> do + mvtys <- mapM typeOf memberValues + case (all Either.isRight mvtys) of + True -> return $ Right $ StructureType isPacked $ Either.rights mvtys + False -> do + let (Left s) = head $ filter Either.isLeft mvtys + return $ Left $ "Could not deduce type for struct field: " ++ s + Just sn -> return $ Right $ NamedTypeReference sn + typeOf (C.Array {..}) = return $ Right $ ArrayType (fromIntegral $ length memberValues) memberType + typeOf (C.Vector {..}) = case memberValues of + [] -> return $ Left "Vectors of size zero are not allowed. (Malformed AST)" + (x:_) -> do + t <- typeOf x + case t of + (Left _) -> return t + (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.Add {..}) = typeOf operand0 typeOf (C.FAdd {..}) = typeOf operand0 typeOf (C.FDiv {..}) = typeOf operand0 @@ -65,73 +81,125 @@ instance Typed C.Constant where typeOf (C.And {..}) = typeOf operand0 typeOf (C.Or {..}) = typeOf operand0 typeOf (C.Xor {..}) = typeOf operand0 - typeOf (C.GetElementPtr {..}) = getElementPtrType (typeOf address) indices - typeOf (C.Trunc {..}) = type' - typeOf (C.ZExt {..}) = type' - typeOf (C.SExt {..}) = type' - typeOf (C.FPToUI {..}) = type' - typeOf (C.FPToSI {..}) = type' - typeOf (C.UIToFP {..}) = type' - typeOf (C.SIToFP {..}) = type' - typeOf (C.FPTrunc {..}) = type' - typeOf (C.FPExt {..}) = type' - typeOf (C.PtrToInt {..}) = type' - typeOf (C.IntToPtr {..}) = type' - typeOf (C.BitCast {..}) = type' - typeOf (C.ICmp {..}) = case (typeOf operand0) of - (VectorType n _) -> VectorType n i1 - _ -> i1 - typeOf (C.FCmp {..}) = case (typeOf operand0) of - (VectorType n _) -> VectorType n i1 - _ -> i1 + typeOf (C.GetElementPtr {..}) = do + aty <- typeOf address + case aty of + (Left _) -> return aty + (Right aty') -> indexTypeByConstants aty' indices + typeOf (C.Trunc {..}) = return $ Right type' + typeOf (C.ZExt {..}) = return $ Right type' + typeOf (C.SExt {..}) = return $ Right type' + typeOf (C.FPToUI {..}) = return $ Right type' + typeOf (C.FPToSI {..}) = return $ Right type' + typeOf (C.UIToFP {..}) = return $ Right type' + typeOf (C.SIToFP {..}) = return $ Right type' + typeOf (C.FPTrunc {..}) = return $ Right type' + typeOf (C.FPExt {..}) = return $ Right type' + typeOf (C.PtrToInt {..}) = return $ Right type' + typeOf (C.IntToPtr {..}) = return $ Right type' + typeOf (C.BitCast {..}) = return $ Right type' + typeOf (C.ICmp {..}) = do + t <- typeOf operand0 + case t of + (Left _) -> return t + (Right (VectorType n _)) -> return $ Right $ VectorType n i1 + (Right _) -> return $ Right i1 + typeOf (C.FCmp {..}) = do + t <- typeOf operand0 + case t of + (Left _) -> return t + (Right (VectorType n _)) -> return $ Right $ VectorType n i1 + (Right _) -> return $ Right i1 typeOf (C.Select {..}) = typeOf trueValue - typeOf (C.ExtractElement {..}) = case typeOf vector of - (VectorType _ t) -> t - _ -> error "The first operand of an extractelement instruction is a value of vector type. (Malformed AST)" + typeOf (C.ExtractElement {..}) = do + t <- typeOf vector + case t of + (Left _) -> return t + (Right (VectorType _ t')) -> return $ Right t' + (Right _) -> return $ Left "The first operand of an extractelement instruction is a value of vector type. (Malformed AST)" typeOf (C.InsertElement {..}) = typeOf vector - typeOf (C.ShuffleVector {..}) = case (typeOf operand0, typeOf mask) of - (VectorType _ t, VectorType m _) -> VectorType m t - _ -> error "The first operand of an shufflevector instruction is a value of vector type. (Malformed AST)" - typeOf (C.ExtractValue {..}) = extractValueType indices' (typeOf aggregate) - typeOf (C.InsertValue {..}) = typeOf aggregate - typeOf (C.TokenNone) = TokenType - typeOf (C.AddrSpaceCast {..}) = type' - -getElementPtrType :: Type -> [C.Constant] -> Type -getElementPtrType ty [] = ptr ty -getElementPtrType (PointerType ty _) (_:is) = getElementPtrType ty is -getElementPtrType (StructureType _ elTys) (C.Int 32 val:is) = - getElementPtrType (elTys !! fromIntegral val) is -getElementPtrType (VectorType _ elTy) (_:is) = getElementPtrType elTy is -getElementPtrType (ArrayType _ elTy) (_:is) = getElementPtrType elTy is -getElementPtrType _ _ = error "Expecting aggregate type. (Malformed AST)" - -getElementType :: Type -> Type -getElementType (PointerType t _) = t -getElementType _ = error $ "Expecting pointer type. (Malformed AST)" - -extractValueType :: [Word32] -> Type -> Type -extractValueType [] ty = ty + typeOf (C.ShuffleVector {..}) = do + t0 <- typeOf operand0 + tm <- typeOf mask + 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. +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 (StructureType _ elTys) (C.Int 32 val:is) = + indexTypeByConstants (elTys !! fromIntegral val) is +indexTypeByConstants (StructureType _ _) (i:_) = + return $ Left $ "Indices into structures should be 32-bit integer constants. (Malformed AST): " ++ show i +indexTypeByConstants (VectorType _ elTy) (_:is) = indexTypeByConstants elTy is +indexTypeByConstants (ArrayType _ elTy) (_:is) = indexTypeByConstants elTy is +indexTypeByConstants (NamedTypeReference n) is = do + mayTy <- liftModuleState (gets (Map.lookup n . builderTypeDefs)) + case mayTy of + Nothing -> return $ Left $ "Couldn’t resolve typedef for: " ++ show n + 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. +indexTypeByOperands :: (HasCallStack, MonadModuleBuilder m) => Type -> [Operand] -> m (Either String Type) +indexTypeByOperands ty [] = return $ Right $ ptr ty +indexTypeByOperands (PointerType ty _) (_:is) = indexTypeByOperands ty is +indexTypeByOperands (StructureType _ elTys) (ConstantOperand (C.Int 32 val):is) = + indexTypeByOperands (elTys !! fromIntegral val) is +indexTypeByOperands (StructureType _ _) (i:_) = + return $ Left $ "Indices into structures should be 32-bit integer constants. (Malformed AST): " ++ show i +indexTypeByOperands (VectorType _ elTy) (_:is) = indexTypeByOperands elTy is +indexTypeByOperands (ArrayType _ elTy) (_:is) = indexTypeByOperands elTy is +indexTypeByOperands (NamedTypeReference n) is = do + mayTy <- liftModuleState (gets (Map.lookup n . builderTypeDefs)) + case mayTy of + Nothing -> return $ Left $ "Couldn’t resolve typedef for: " ++ show n + 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) | fromIntegral i < numEls = extractValueType is elTy - | fromIntegral i >= numEls = error "Expecting valid index into array type. (Malformed AST)" + | fromIntegral i >= numEls = return $ Left $ "Expecting valid index into array type. (Malformed AST): " ++ show i extractValueType (i : is) (StructureType _ elTys) | fromIntegral i < length elTys = extractValueType is (elTys !! fromIntegral i) - | otherwise = error "Expecting valid index into structure type. (Malformed AST)" -extractValueType _ _ = error "Expecting vector type. (Malformed AST)" + | otherwise = return $ Left $ "Expecting valid index into structure type. (Malformed AST): " ++ show i +extractValueType _ ty = return $ Left $ "Expecting vector type. (Malformed AST): " ++ show ty instance Typed F.SomeFloat where - typeOf (F.Half _) = FloatingPointType HalfFP - typeOf (F.Single _) = FloatingPointType FloatFP - typeOf (F.Double _) = FloatingPointType DoubleFP - typeOf (F.Quadruple _ _) = FloatingPointType FP128FP - typeOf (F.X86_FP80 _ _) = FloatingPointType X86_FP80FP - typeOf (F.PPC_FP128 _ _) = FloatingPointType PPC_FP128FP + typeOf (F.Half _) = return $ Right $ FloatingPointType HalfFP + typeOf (F.Single _) = return $ Right $ FloatingPointType FloatFP + typeOf (F.Double _) = return $ Right $ FloatingPointType DoubleFP + typeOf (F.Quadruple _ _) = return $ Right $ FloatingPointType FP128FP + typeOf (F.X86_FP80 _ _) = return $ Right $ FloatingPointType X86_FP80FP + typeOf (F.PPC_FP128 _ _) = return $ Right $ FloatingPointType PPC_FP128FP instance Typed Global where - typeOf (GlobalVariable {..}) = type' - typeOf (GlobalAlias {..}) = type' - typeOf (Function {..}) = let (params, isVarArg) = parameters - in FunctionType returnType (map typeOf params) isVarArg + typeOf (GlobalVariable {..}) = return $ Right $ type' + typeOf (GlobalAlias {..}) = return $ Right $ type' + typeOf (Function {..}) = do + let (params, isVarArg) = parameters + ptys <- mapM typeOf params + case (all Either.isRight ptys) of + True -> return $ Right $ FunctionType returnType (Either.rights ptys) isVarArg + False -> do + let (Left s) = head $ filter Either.isLeft ptys + return $ Left $ "Could not deduce type for function parameter: " ++ s + instance Typed Parameter where - typeOf (Parameter t _ _) = t + typeOf (Parameter t _ _) = return $ Right t diff --git a/llvm-hs-pure/src/LLVM/IRBuilder/Constant.hs b/llvm-hs-pure/src/LLVM/IRBuilder/Constant.hs index 283185ff..fe39ab00 100644 --- a/llvm-hs-pure/src/LLVM/IRBuilder/Constant.hs +++ b/llvm-hs-pure/src/LLVM/IRBuilder/Constant.hs @@ -6,6 +6,9 @@ import LLVM.AST.Typed import LLVM.AST.Constant import LLVM.AST.Float +import LLVM.IRBuilder.Module + +import GHC.Stack int64 :: Integer -> Operand int64 = ConstantOperand . Int 64 @@ -28,5 +31,9 @@ half = ConstantOperand . Float . Half struct :: Maybe Name -> Bool -> [Constant] -> Operand struct nm packing members = ConstantOperand $ Struct nm packing members -array :: [Constant] -> Operand -array members = ConstantOperand $ Array (typeOf $ head members) members +array :: (HasCallStack, MonadModuleBuilder m) => [Constant] -> m Operand +array members = do + thm <- typeOf $ head members + case thm of + (Left s) -> error s + (Right thm') -> return $ ConstantOperand $ Array thm' members diff --git a/llvm-hs-pure/src/LLVM/IRBuilder/Instruction.hs b/llvm-hs-pure/src/LLVM/IRBuilder/Instruction.hs index 7160ed34..5ae9de3e 100644 --- a/llvm-hs-pure/src/LLVM/IRBuilder/Instruction.hs +++ b/llvm-hs-pure/src/LLVM/IRBuilder/Instruction.hs @@ -4,8 +4,6 @@ module LLVM.IRBuilder.Instruction where import Prelude hiding (and, or, pred) -import Control.Monad.State (gets) -import qualified Data.Map.Lazy as Map import Data.Word import Data.Char (ord) import GHC.Stack @@ -27,88 +25,164 @@ import LLVM.IRBuilder.Monad import LLVM.IRBuilder.Module -- | See . -fadd :: MonadIRBuilder m => Operand -> Operand -> m Operand -fadd a b = emitInstr (typeOf a) $ FAdd noFastMathFlags a b [] +fadd :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand +fadd a b = do + ta <- typeOf a + case ta of + (Left s) -> error s + (Right ta') -> emitInstr ta' $ FAdd noFastMathFlags a b [] -- | See . -fmul :: MonadIRBuilder m => Operand -> Operand -> m Operand -fmul a b = emitInstr (typeOf a) $ FMul noFastMathFlags a b [] +fmul :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand +fmul a b = do + ta <- typeOf a + case ta of + (Left s) -> error s + (Right ta') -> emitInstr ta' $ FMul noFastMathFlags a b [] -- | See . -fsub :: MonadIRBuilder m => Operand -> Operand -> m Operand -fsub a b = emitInstr (typeOf a) $ FSub noFastMathFlags a b [] +fsub :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand +fsub a b = do + ta <- typeOf a + case ta of + (Left s) -> error s + (Right ta') -> emitInstr ta' $ FSub noFastMathFlags a b [] -- | See . -fdiv :: MonadIRBuilder m => Operand -> Operand -> m Operand -fdiv a b = emitInstr (typeOf a) $ FDiv noFastMathFlags a b [] +fdiv :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand +fdiv a b = do + ta <- typeOf a + case ta of + (Left s) -> error s + (Right ta') -> emitInstr ta' $ FDiv noFastMathFlags a b [] -- | See . -frem :: MonadIRBuilder m => Operand -> Operand -> m Operand -frem a b = emitInstr (typeOf a) $ FRem noFastMathFlags a b [] +frem :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand +frem a b = do + ta <- typeOf a + case ta of + (Left s) -> error s + (Right ta') -> emitInstr ta' $ FRem noFastMathFlags a b [] -- | See . -add :: MonadIRBuilder m => Operand -> Operand -> m Operand -add a b = emitInstr (typeOf a) $ Add False False a b [] +add :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand +add a b = do + ta <- typeOf a + case ta of + (Left s) -> error s + (Right ta') -> emitInstr ta' $ Add False False a b [] -- | See . -mul :: MonadIRBuilder m => Operand -> Operand -> m Operand -mul a b = emitInstr (typeOf a) $ Mul False False a b [] +mul :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand +mul a b = do + ta <- typeOf a + case ta of + (Left s) -> error s + (Right ta') -> emitInstr ta' $ Mul False False a b [] -- | See . -sub :: MonadIRBuilder m => Operand -> Operand -> m Operand -sub a b = emitInstr (typeOf a) $ Sub False False a b [] +sub :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand +sub a b = do + ta <- typeOf a + case ta of + (Left s) -> error s + (Right ta') -> emitInstr ta' $ Sub False False a b [] -- | See . -udiv :: MonadIRBuilder m => Operand -> Operand -> m Operand -udiv a b = emitInstr (typeOf a) $ UDiv False a b [] +udiv :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand +udiv a b = do + ta <- typeOf a + case ta of + (Left s) -> error s + (Right ta') -> emitInstr ta' $ UDiv False a b [] -- | See . -sdiv :: MonadIRBuilder m => Operand -> Operand -> m Operand -sdiv a b = emitInstr (typeOf a) $ SDiv False a b [] +sdiv :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand +sdiv a b = do + ta <- typeOf a + case ta of + (Left s) -> error s + (Right ta') -> emitInstr ta' $ SDiv False a b [] -- | See . -urem :: MonadIRBuilder m => Operand -> Operand -> m Operand -urem a b = emitInstr (typeOf a) $ URem a b [] +urem :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand +urem a b = do + ta <- typeOf a + case ta of + (Left s) -> error s + (Right ta') -> emitInstr ta' $ URem a b [] -- | See . -srem :: MonadIRBuilder m => Operand -> Operand -> m Operand -srem a b = emitInstr (typeOf a) $ SRem a b [] +srem :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand +srem a b = do + ta <- typeOf a + case ta of + (Left s) -> error s + (Right ta') -> emitInstr ta' $ SRem a b [] -- | See . -shl :: MonadIRBuilder m => Operand -> Operand -> m Operand -shl a b = emitInstr (typeOf a) $ Shl False False a b [] +shl :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand +shl a b = do + ta <- typeOf a + case ta of + (Left s) -> error s + (Right ta') -> emitInstr ta' $ Shl False False a b [] -- | See . -lshr :: MonadIRBuilder m => Operand -> Operand -> m Operand -lshr a b = emitInstr (typeOf a) $ LShr True a b [] +lshr :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand +lshr a b = do + ta <- typeOf a + case ta of + (Left s) -> error s + (Right ta') -> emitInstr ta' $ LShr True a b [] -- | See . -ashr :: MonadIRBuilder m => Operand -> Operand -> m Operand -ashr a b = emitInstr (typeOf a) $ AShr True a b [] +ashr :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand +ashr a b = do + ta <- typeOf a + case ta of + (Left s) -> error s + (Right ta') -> emitInstr ta' $ AShr True a b [] -- | See . -and :: MonadIRBuilder m => Operand -> Operand -> m Operand -and a b = emitInstr (typeOf a) $ And a b [] +and :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand +and a b = do + ta <- typeOf a + case ta of + (Left s) -> error s + (Right ta') -> emitInstr ta' $ And a b [] -- | See . -or :: MonadIRBuilder m => Operand -> Operand -> m Operand -or a b = emitInstr (typeOf a) $ Or a b [] +or :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand +or a b = do + ta <- typeOf a + case ta of + (Left s) -> error s + (Right ta') -> emitInstr ta' $ Or a b [] -- | See . -xor :: MonadIRBuilder m => Operand -> Operand -> m Operand -xor a b = emitInstr (typeOf a) $ Xor a b [] +xor :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand +xor a b = do + ta <- typeOf a + case ta of + (Left s) -> error s + (Right ta') -> emitInstr ta' $ Xor a b [] -- | See . alloca :: MonadIRBuilder m => Type -> Maybe Operand -> Word32 -> m Operand alloca ty count align = emitInstr (ptr ty) $ Alloca ty count align [] -- | See . -load :: HasCallStack => MonadIRBuilder m => Operand -> Word32 -> m Operand -load a align = emitInstr retty $ Load False a Nothing align [] - where - retty = case typeOf a of - PointerType ty _ -> ty - _ -> error "Cannot load non-pointer (Malformed AST)." +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 [] -- | See . store :: MonadIRBuilder m => Operand -> Word32 -> Operand -> m () @@ -116,30 +190,16 @@ store addr align val = emitInstrVoid $ Store False addr val Nothing align [] -- | Emit the @getelementptr@ instruction. -- See . -gep :: (MonadIRBuilder m, MonadModuleBuilder m, HasCallStack) => Operand -> [Operand] -> m Operand +gep :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> [Operand] -> m Operand gep addr is = do - ty <- ptr <$> gepType "gep" (typeOf addr) is - emitInstr ty (GetElementPtr False addr is []) - --- TODO: Perhaps use the function from llvm-hs-pretty (https://github.com/llvm-hs/llvm-hs-pretty/blob/master/src/LLVM/Typed.hs) -gepType :: (MonadModuleBuilder m, HasCallStack) => String -> Type -> [Operand] -> m Type -gepType caller = go - where - msg m = caller ++ ": " ++ m - - go ty [] = pure ty - go (PointerType ty _) (_:is') = go ty is' - go (StructureType _ elTys) (ConstantOperand (C.Int 32 val):is') = - go (elTys !! fromIntegral val) is' - go (StructureType _ _) (i:_) = error $ msg ("Indices into structures should be 32-bit constants. " ++ show i) - go (VectorType _ elTy) (_:is') = go elTy is' - go (ArrayType _ elTy) (_:is') = go elTy is' - go (NamedTypeReference nm) is' = do - mayTy <- liftModuleState (gets (Map.lookup nm . builderTypeDefs)) - case mayTy of - Nothing -> error $ msg ("Couldn’t resolve typedef for: " ++ show nm) - Just ty -> go ty is' - go t (_:_) = error $ msg ("Can't index into a " ++ show t) + 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 []) -- | Emit the @trunc ... to@ instruction. -- See . @@ -202,41 +262,55 @@ bitcast :: MonadIRBuilder m => Operand -> Type -> m Operand bitcast a to = emitInstr to $ BitCast a to [] -- | See . -extractElement :: (MonadIRBuilder m, HasCallStack) => Operand -> Operand -> m Operand -extractElement v i = emitInstr elemTyp $ ExtractElement v i [] - where elemTyp = - case typeOf v of - VectorType _ typ -> typ - _ -> error "extractElement: Expected a vector type (malformed AST)." +extractElement :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand +extractElement v i = do + tv <- typeOf v + let elemTyp = case tv of + (Left s) -> error s + (Right (VectorType _ typ)) -> typ + (Right typ) -> error $ "extractElement: Expected a vector type but got " ++ show typ ++ " (Malformed AST)." + emitInstr elemTyp $ ExtractElement v i [] -- | See . -insertElement :: MonadIRBuilder m => Operand -> Operand -> Operand -> m Operand -insertElement v e i = emitInstr (typeOf v) $ InsertElement v e i [] +insertElement :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> Operand -> m Operand +insertElement v e i = do + tv <- typeOf v + case tv of + (Left s) -> error s + (Right tv') -> emitInstr tv' $ InsertElement v e i [] -- | See . -shuffleVector :: (MonadIRBuilder m, HasCallStack) => Operand -> Operand -> C.Constant -> m Operand -shuffleVector a b m = emitInstr retType $ ShuffleVector a b m [] - where retType = - case (typeOf a, typeOf m) of - (VectorType _ elemTyp, VectorType maskLength _) -> VectorType maskLength elemTyp - _ -> error "shuffleVector: Expected two vectors and a vector mask" +shuffleVector :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> C.Constant -> m Operand +shuffleVector a b m = do + ta <- typeOf a + tm <- typeOf m + let retType = case (ta, tm) of + (Right (VectorType _ elemTyp), Right (VectorType maskLength _)) -> VectorType maskLength elemTyp + _ -> error "shuffleVector: Expected two vectors and a vector mask" + emitInstr retType $ ShuffleVector a b m [] -- | See . -extractValue :: (MonadIRBuilder m, MonadModuleBuilder m, HasCallStack) => Operand -> [Word32] -> m Operand +extractValue :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> [Word32] -> m Operand extractValue a i = do - retType <- gepType "extractValue" aggType (map (ConstantOperand . C.Int 32 . fromIntegral) i) - emitInstr retType $ ExtractValue a i [] - where - aggType = - case typeOf a of - typ@ArrayType{} -> typ - typ@NamedTypeReference{} -> typ - typ@StructureType{} -> typ - _ -> error "extractValue: Expecting structure or array type. (Malformed AST)" + ta <- typeOf a + let aggType = case ta of + (Left s) -> error s + (Right typ@ArrayType{}) -> typ + (Right typ@NamedTypeReference{}) -> typ + (Right typ@StructureType{}) -> typ + (Right typ) -> error $ "extractValue: Expecting structure or array type but got " ++ show typ ++ " (Malformed AST)." + 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 [] -- | See . -insertValue :: MonadIRBuilder m => Operand -> Operand -> [Word32] -> m Operand -insertValue a e i = emitInstr (typeOf a) $ InsertValue a e i [] +insertValue :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> [Word32] -> m Operand +insertValue a e i = do + ta <- typeOf a + case ta of + (Left s) -> error s + (Right ta') -> emitInstr ta' $ InsertValue a e i [] -- | See . icmp :: MonadIRBuilder m => IP.IntegerPredicate -> Operand -> Operand -> m Operand @@ -253,11 +327,13 @@ br :: MonadIRBuilder m => Name -> m () br val = emitTerm (Br val []) -- | See . -phi :: MonadIRBuilder m => [(Operand, Name)] -> m Operand +phi :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => [(Operand, Name)] -> m Operand phi [] = emitInstr AST.void $ Phi AST.void [] [] -phi incoming@(i:_) = emitInstr ty $ Phi ty incoming [] - where - ty = typeOf (fst i) -- result type +phi incoming@(i:_) = do + ty <- typeOf (fst i) + case ty of + (Left s) -> error s + (Right ty') -> emitInstr ty' $ Phi ty' incoming [] -- | Emit a @ret void@ instruction. -- See . @@ -265,7 +341,7 @@ retVoid :: MonadIRBuilder m => m () retVoid = emitTerm (Ret Nothing []) -- | See . -call :: (MonadIRBuilder m, HasCallStack) => Operand -> [(Operand, [ParameterAttribute])] -> m Operand +call :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> [(Operand, [ParameterAttribute])] -> m Operand call fun args = do let instr = Call { AST.tailCallKind = Nothing @@ -276,14 +352,16 @@ call fun args = do , AST.functionAttributes = [] , AST.metadata = [] } - case typeOf fun of - FunctionType r _ _ -> case r of - VoidType -> emitInstrVoid instr >> (pure (ConstantOperand (C.Undef void))) - _ -> emitInstr r instr - PointerType (FunctionType r _ _) _ -> case r of - VoidType -> emitInstrVoid instr >> (pure (ConstantOperand (C.Undef void))) - _ -> emitInstr r instr - _ -> error "Cannot call non-function (Malformed AST)." + 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 + VoidType -> emitInstrVoid instr >> (pure (ConstantOperand (C.Undef void))) + _ -> emitInstr r instr + (Right _) -> error "Cannot call non-function (Malformed AST)." -- | See . ret :: MonadIRBuilder m => Operand -> m () @@ -294,8 +372,12 @@ switch :: MonadIRBuilder m => Operand -> Name -> [(C.Constant, Name)] -> m () switch val def dests = emitTerm $ Switch val def dests [] -- | See . -select :: MonadIRBuilder m => Operand -> Operand -> Operand -> m Operand -select cond t f = emitInstr (typeOf t) $ Select cond t f [] +select :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> Operand -> m Operand +select cond t f = do + tt <- typeOf t + case tt of + (Left s) -> error s + (Right tt') -> emitInstr tt' $ Select cond t f [] -- | Conditional branch (see 'br' for unconditional instructions). -- See . @@ -309,7 +391,7 @@ unreachable = emitTerm $ Unreachable [] -- | Creates a series of instructions to generate a pointer to a string -- constant. Useful for making format strings to pass to @printf@, for example globalStringPtr - :: (MonadModuleBuilder m) + :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => String -- ^ The string to generate -> Name -- ^ Variable name of the pointer -> m C.Constant @@ -318,20 +400,23 @@ globalStringPtr str nm = do llvmVals = map (C.Int 8) (asciiVals ++ [0]) -- append null terminator char = IntegerType 8 charArray = C.Array char llvmVals - ty = LLVM.AST.Typed.typeOf charArray - emitDefn $ GlobalDefinition globalVariableDefaults - { name = nm - , LLVM.AST.Global.type' = ty - , linkage = External - , isConstant = True - , initializer = Just charArray - , unnamedAddr = Just GlobalAddr - } - return $ C.GetElementPtr True - (C.GlobalReference (ptr ty) nm) - [(C.Int 32 0), (C.Int 32 0)] - -sizeof :: (MonadModuleBuilder m, MonadIRBuilder m) => Word32 -> Type -> m Operand + ty <- LLVM.AST.Typed.typeOf charArray + case ty of + (Left s) -> error s + (Right ty') -> do + emitDefn $ GlobalDefinition globalVariableDefaults + { name = nm + , LLVM.AST.Global.type' = ty' + , linkage = External + , isConstant = True + , initializer = Just charArray + , unnamedAddr = Just GlobalAddr + } + return $ C.GetElementPtr True + (C.GlobalReference (ptr ty') 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] diff --git a/llvm-hs-pure/src/LLVM/IRBuilder/Monad.hs b/llvm-hs-pure/src/LLVM/IRBuilder/Monad.hs index d5a03a6b..45e379a6 100644 --- a/llvm-hs-pure/src/LLVM/IRBuilder/Monad.hs +++ b/llvm-hs-pure/src/LLVM/IRBuilder/Monad.hs @@ -29,6 +29,7 @@ import Control.Monad.Trans.Identity #endif import Data.Bifunctor +import Data.Monoid (First(..)) import Data.String import Data.Map.Strict(Map) import qualified Data.Map.Strict as M @@ -68,11 +69,11 @@ instance Monad m => MonadIRBuilder (IRBuilderT m) where data PartialBlock = PartialBlock { partialBlockName :: !Name , partialBlockInstrs :: SnocList (Named Instruction) - , partialBlockTerm :: Maybe (Named Terminator) + , partialBlockTerm :: First (Named Terminator) } emptyPartialBlock :: Name -> PartialBlock -emptyPartialBlock nm = PartialBlock nm mempty Nothing +emptyPartialBlock nm = PartialBlock nm mempty (First Nothing) -- | Builder monad state data IRBuilderState = IRBuilderState @@ -198,7 +199,7 @@ emitTerm => Terminator -> m () emitTerm term = modifyBlock $ \bb -> bb - { partialBlockTerm = Just (Do term) + { partialBlockTerm = partialBlockTerm bb <> First (Just (Do term)) } -- | Starts a new block labelled using the given name and ends the previous @@ -214,7 +215,7 @@ emitBlockStart nm = do Just bb -> do let instrs = getSnocList $ partialBlockInstrs bb - newBb = case partialBlockTerm bb of + newBb = case getFirst (partialBlockTerm bb) of Nothing -> BasicBlock (partialBlockName bb) instrs (Do (Ret Nothing [])) Just term -> BasicBlock (partialBlockName bb) instrs term liftIRState $ modify $ \s -> s @@ -270,7 +271,7 @@ hasTerminator = do current <- liftIRState $ gets builderBlock case current of Nothing -> error "Called hasTerminator when no block was active" - Just blk -> case partialBlockTerm blk of + Just blk -> case getFirst (partialBlockTerm blk) of Nothing -> return False Just _ -> return True diff --git a/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs b/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs index bc78accb..52cb7fe4 100644 --- a/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs +++ b/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs @@ -10,7 +10,8 @@ import Test.Tasty.HUnit import LLVM.AST hiding (function) import qualified LLVM.AST.Constant as C import qualified LLVM.AST.Float as F -import LLVM.AST.Global (basicBlocks, name, parameters, returnType) +import qualified LLVM.AST.Global +import LLVM.AST.Linkage (Linkage(..)) import qualified LLVM.AST.Type as AST import qualified LLVM.AST.CallingConvention as CC import qualified LLVM.AST.Instruction as I (function) @@ -26,15 +27,15 @@ tests = moduleName = "exampleModule", moduleDefinitions = [ GlobalDefinition functionDefaults { - name = "add", - parameters = + LLVM.AST.Global.name = "add", + LLVM.AST.Global.parameters = ( [ Parameter AST.i32 "a_0" [] , Parameter AST.i32 "b_0" [] ] , False ), - returnType = AST.i32, - basicBlocks = + LLVM.AST.Global.returnType = AST.i32, + LLVM.AST.Global.basicBlocks = [ BasicBlock "entry_0" [ UnName 0 := Add { @@ -52,7 +53,9 @@ tests = } , testCase "calls constant globals" callWorksWithConstantGlobals , testCase "supports recursive function calls" recursiveFunctionCalls - , testCase "resolves typefes" resolvesTypeDefs + , testCase "resolves typedefs" resolvesTypeDefs + , testCase "resolves constant typedefs" resolvesConstantTypeDefs + , testCase "handling of terminator" terminatorHandling , testCase "builds the example" $ do let f10 = ConstantOperand (C.Float (F.Double 10)) fadd a b = FAdd { operand0 = a, operand1 = b, fastMathFlags = noFastMathFlags, metadata = [] } @@ -62,9 +65,9 @@ tests = moduleName = "exampleModule", moduleDefinitions = [ GlobalDefinition functionDefaults { - name = "foo", - returnType = AST.double, - basicBlocks = + LLVM.AST.Global.name = "foo", + LLVM.AST.Global.returnType = AST.double, + LLVM.AST.Global.basicBlocks = [ BasicBlock (UnName 0) [ "xxx_0" := fadd f10 f10] (Do (Ret Nothing [])) , BasicBlock @@ -97,9 +100,9 @@ tests = ] } , GlobalDefinition functionDefaults { - name = "bar", - returnType = AST.double, - basicBlocks = + LLVM.AST.Global.name = "bar", + LLVM.AST.Global.returnType = AST.double, + LLVM.AST.Global.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := fadd f10 f10 @@ -109,15 +112,15 @@ tests = ] } , GlobalDefinition functionDefaults { - name = "baz", - parameters = + LLVM.AST.Global.name = "baz", + LLVM.AST.Global.parameters = ( [ Parameter AST.i32 (UnName 0) [] , Parameter AST.double "arg_0" [] , Parameter AST.i32 (UnName 1) [] , Parameter AST.double "arg_1" []] , False), - returnType = AST.double, - basicBlocks = + LLVM.AST.Global.returnType = AST.double, + LLVM.AST.Global.basicBlocks = [ BasicBlock (UnName 2) [] @@ -175,10 +178,10 @@ recursiveFunctionCalls = do { moduleName = "exampleModule" , moduleDefinitions = [ GlobalDefinition functionDefaults - { returnType = AST.i32 - , name = Name "f" - , parameters = ([Parameter AST.i32 "a_0" []], False) - , basicBlocks = + { LLVM.AST.Global.returnType = AST.i32 + , LLVM.AST.Global.name = Name "f" + , LLVM.AST.Global.parameters = ([Parameter AST.i32 "a_0" []], False) + , LLVM.AST.Global.basicBlocks = [ BasicBlock (Name "entry_0") [ UnName 0 := Call { tailCallKind = Nothing @@ -210,16 +213,16 @@ callWorksWithConstantGlobals = do { moduleName = "exampleModule" , moduleDefinitions = [ GlobalDefinition functionDefaults { - returnType = AST.ptr AST.i8, - name = Name "malloc", - parameters = ([Parameter (IntegerType {typeBits = 64}) (Name "") []],False), - basicBlocks = [] + LLVM.AST.Global.returnType = AST.ptr AST.i8, + LLVM.AST.Global.name = Name "malloc", + LLVM.AST.Global.parameters = ([Parameter (IntegerType {typeBits = 64}) (Name "") []],False), + LLVM.AST.Global.basicBlocks = [] } , GlobalDefinition functionDefaults { - returnType = VoidType, - name = Name "omg", - parameters = ([],False), - basicBlocks = [ + LLVM.AST.Global.returnType = VoidType, + LLVM.AST.Global.name = Name "omg", + LLVM.AST.Global.parameters = ([],False), + LLVM.AST.Global.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Call { tailCallKind = Nothing , I.function = Right ( @@ -263,13 +266,13 @@ resolvesTypeDefs = do , moduleDefinitions = [ TypeDefinition "pair" (Just (StructureType False [AST.i32, AST.i32])) , GlobalDefinition functionDefaults - { name = "f" - , parameters = ( [ Parameter (AST.ptr (NamedTypeReference "pair")) "ptr_0" [] + { LLVM.AST.Global.name = "f" + , LLVM.AST.Global.parameters = ( [ Parameter (AST.ptr (NamedTypeReference "pair")) "ptr_0" [] , Parameter AST.i32 "x_0" [] , Parameter AST.i32 "y_0" []] , False) - , returnType = AST.void - , basicBlocks = + , LLVM.AST.Global.returnType = AST.void + , LLVM.AST.Global.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := GetElementPtr { inBounds = False @@ -304,11 +307,11 @@ resolvesTypeDefs = do ] } , GlobalDefinition functionDefaults - { name = "g" - , parameters = ( [Parameter (NamedTypeReference "pair") "pair_0" []] + { LLVM.AST.Global.name = "g" + , LLVM.AST.Global.parameters = ( [Parameter (NamedTypeReference "pair") "pair_0" []] , False) - , returnType = AST.i32 - , basicBlocks = + , LLVM.AST.Global.returnType = AST.i32 + , LLVM.AST.Global.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := ExtractValue { aggregate = LocalReference (NamedTypeReference "pair") "pair_0" @@ -333,6 +336,217 @@ resolvesTypeDefs = do } ]} +resolvesConstantTypeDefs :: Assertion +resolvesConstantTypeDefs = do + buildModule "" builder @?= ast + where builder = mdo + 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)] + store xPtr 0 x + store yPtr 0 y + function "g" [] AST.i32 $ \[] -> do + pair <- load (ConstantOperand $ C.GlobalReference (AST.ptr pairTy) "gpair") 0 + x <- extractValue pair [0] + y <- extractValue pair [1] + z <- add x y + ret z + pure () + ast = defaultModule + { moduleName = "" + , moduleDefinitions = + [ TypeDefinition "pair" (Just (StructureType False [AST.i32, AST.i32])) + , GlobalDefinition globalVariableDefaults + { LLVM.AST.Global.name = "gpair" + , LLVM.AST.Global.type' = NamedTypeReference "pair" + , LLVM.AST.Global.linkage = External + , LLVM.AST.Global.initializer = Just (C.AggregateZero (NamedTypeReference "pair")) + } + , GlobalDefinition functionDefaults + { LLVM.AST.Global.name = "f" + , LLVM.AST.Global.parameters = ( [ Parameter AST.i32 "x_0" [] + , Parameter AST.i32 "y_0" []] + , False) + , LLVM.AST.Global.returnType = AST.void + , LLVM.AST.Global.basicBlocks = + [ BasicBlock (UnName 0) + [ UnName 1 := GetElementPtr + { inBounds = False + , address = ConstantOperand (C.GlobalReference (AST.ptr (NamedTypeReference "pair")) "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") + , indices = [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] + , metadata = [] + } + , Do $ Store + { volatile = False + , address = LocalReference (AST.ptr AST.i32) (UnName 1) + , value = LocalReference AST.i32 "x_0" + , maybeAtomicity = Nothing + , alignment = 0 + , metadata = [] + } + , Do $ Store + { volatile = False + , address = LocalReference (AST.ptr AST.i32) (UnName 2) + , value = LocalReference AST.i32 "y_0" + , maybeAtomicity = Nothing + , alignment = 0 + , metadata = [] + } + ] + (Do (Ret Nothing [])) + ] + } + , GlobalDefinition functionDefaults + { LLVM.AST.Global.name = "g" + , LLVM.AST.Global.parameters = ([], False) + , LLVM.AST.Global.returnType = AST.i32 + , LLVM.AST.Global.basicBlocks = + [ BasicBlock (UnName 0) + [ UnName 1 := Load + { volatile = False, + address = ConstantOperand (C.GlobalReference (AST.ptr (NamedTypeReference "pair")) "gpair"), + maybeAtomicity = Nothing, + alignment = 0, + metadata = [] + } + , UnName 2 := ExtractValue + { aggregate = LocalReference (NamedTypeReference "pair") (UnName 1) + , indices' = [0] + , metadata = [] + } + , UnName 3 := ExtractValue + { aggregate = LocalReference (NamedTypeReference "pair") (UnName 1) + , indices' = [1] + , metadata = [] + } + , UnName 4 := Add + { nsw = False + , nuw = False + , operand0 = LocalReference AST.i32 (UnName 2) + , operand1 = LocalReference AST.i32 (UnName 3) + , metadata = [] + } + ] + (Do (Ret (Just (LocalReference AST.i32 (UnName 4))) [])) + ] + } + ]} + +terminatorHandling :: Assertion +terminatorHandling = do + firstTerminatorWins @?= firstWinsAst + terminatorsCompose @?= terminatorsComposeAst + nestedControlFlowWorks @?= nestedControlFlowAst + where + firstTerminatorWins = buildModule "firstTerminatorWinsModule" $ mdo + function "f" [(AST.i32, "a"), (AST.i32, "b")] AST.i32 $ \[a, b] -> mdo + + entry <- block `named` "entry"; do + c <- add a b + d <- add a c + ret c + ret d + terminatorsCompose = buildModule "terminatorsComposeModule" $ mdo + function "f" [(AST.i1, "a")] AST.i1 $ \[a] -> mdo + + entry <- block `named` "entry"; do + if' a $ do + ret (bit 0) + + ret (bit 1) + nestedControlFlowWorks = buildModule "nestedControlFlowWorksModule" $ mdo + function "f" [(AST.i1, "a"), (AST.i1, "b")] AST.i1 $ \[a, b] -> mdo + + entry <- block `named` "entry"; do + if' a $ do + if' b $ do + ret (bit 0) + + ret (bit 1) + if' cond asm = mdo + condBr cond ifBlock end + ifBlock <- block `named` "if.begin" + asm + br end + end <- block `named` "if.end" + return () + + firstWinsAst = defaultModule + { moduleName = "firstTerminatorWinsModule" + , moduleDefinitions = + [ GlobalDefinition functionDefaults + { LLVM.AST.Global.name = "f" + , LLVM.AST.Global.parameters = ([ Parameter AST.i32 "a_0" [], Parameter AST.i32 "b_0" []], False) + , LLVM.AST.Global.returnType = AST.i32 + , LLVM.AST.Global.basicBlocks = + [ BasicBlock (Name "entry_0") + [ UnName 0 := Add { nsw = False, nuw = False, metadata = [] + , operand0 = LocalReference (IntegerType {typeBits = 32}) (Name "a_0") + , operand1 = LocalReference (IntegerType {typeBits = 32}) (Name "b_0") + } + , UnName 1 := Add { nsw = False, nuw = False, metadata = [] + , operand0 = LocalReference (IntegerType {typeBits = 32}) (Name "a_0") + , operand1 = LocalReference (IntegerType {typeBits = 32}) (UnName 0) + } + ] + (Do (Ret {returnOperand = Just (LocalReference (IntegerType {typeBits = 32}) (UnName 0)), metadata' = []}))] + } + ]} + terminatorsComposeAst = defaultModule + { moduleName = "terminatorsComposeModule" + , moduleDefinitions = + [ GlobalDefinition functionDefaults + { LLVM.AST.Global.name = "f" + , LLVM.AST.Global.parameters = ([ Parameter AST.i1 "a_0" []], False) + , LLVM.AST.Global.returnType = AST.i1 + , LLVM.AST.Global.basicBlocks = + [ BasicBlock (Name "entry_0") + [] + (Do (CondBr {condition = LocalReference (IntegerType {typeBits = 1}) (Name "a_0") + , trueDest = Name "if.begin_0" + , falseDest = Name "if.end_0", metadata' = []})) + , BasicBlock (Name "if.begin_0") + [] + (Do (Ret {returnOperand = Just (ConstantOperand (C.Int {C.integerBits = 1, C.integerValue = 0})), metadata' = []})) + , BasicBlock (Name "if.end_0") + [] + (Do (Ret {returnOperand = Just (ConstantOperand (C.Int {C.integerBits = 1, C.integerValue = 1})), metadata' = []}))] + } + ]} + nestedControlFlowAst = defaultModule + { moduleName = "nestedControlFlowWorksModule" + , moduleDefinitions = + [ GlobalDefinition functionDefaults + { LLVM.AST.Global.name = "f" + , LLVM.AST.Global.parameters = ([ Parameter AST.i1 "a_0" [], Parameter AST.i1 "b_0" []], False) + , LLVM.AST.Global.returnType = AST.i1 + , LLVM.AST.Global.basicBlocks = + [ BasicBlock (Name "entry_0") + [] + (Do (CondBr { condition = LocalReference (IntegerType {typeBits = 1}) (Name "a_0") + , trueDest = Name "if.begin_0" + , falseDest = Name "if.end_1" + , metadata' = []})) + , BasicBlock (Name "if.begin_0") [] (Do (CondBr { condition = LocalReference (IntegerType {typeBits = 1}) (Name "b_0") + , trueDest = Name "if.begin_1" + , falseDest = Name "if.end_0" + , metadata' = []})) + , BasicBlock (Name "if.begin_1") [] (Do (Ret {returnOperand = Just (ConstantOperand (C.Int {C.integerBits = 1, C.integerValue = 0})), metadata' = []})) + , BasicBlock (Name "if.end_0") [] (Do (Br {dest = Name "if.end_1", metadata' = []})) + , BasicBlock (Name "if.end_1") [] (Do (Ret {returnOperand = Just (ConstantOperand (C.Int {C.integerBits = 1, C.integerValue = 1})), metadata' = []})) + ] + } + ]} + simple :: Module simple = buildModule "exampleModule" $ mdo diff --git a/llvm-hs/CHANGELOG.md b/llvm-hs/CHANGELOG.md index 9d7990bb..6fa34adf 100644 --- a/llvm-hs/CHANGELOG.md +++ b/llvm-hs/CHANGELOG.md @@ -1,3 +1,12 @@ +## 9.0.1.1 (2021-06-XX) + +* Eliminate hard-coded assumption of 32-bit `size_t` +* Handle type resolution through `NamedTypeReference` correctly: type resolution in LLVM depends on module state by design +* Support the LLVM `NoFree` attribute +* Support unbracketed management of `Module`, `Context` with explicit creation and destruction functions +* Add basic support for the OrcJITv2 API +* Various small fixes and improvements to eliminate build warnings + ## 9.0.1 (2019-09-28) * Fix build with Clang on MacOS. diff --git a/llvm-hs/llvm-hs.cabal b/llvm-hs/llvm-hs.cabal index 237f9636..97be1656 100644 --- a/llvm-hs/llvm-hs.cabal +++ b/llvm-hs/llvm-hs.cabal @@ -1,9 +1,9 @@ name: llvm-hs -version: 9.0.1 +version: 9.0.1.1 license: BSD3 license-file: LICENSE -author: Anthony Cowley, Stephen Diehl, Moritz Kiefer , Benjamin S. Scarlet -maintainer: Anthony Cowley, Stephen Diehl, Moritz Kiefer +author: Anthony Cowley, Stephen Diehl, Moritz Kiefer , Andrew Anderson , Benjamin S. Scarlet +maintainer: Anthony Cowley, Stephen Diehl, Moritz Kiefer , Andrew Anderson copyright: (c) 2013 Benjamin S. Scarlet and Google Inc. homepage: http://github.com/llvm-hs/llvm-hs/ bug-reports: http://github.com/llvm-hs/llvm-hs/issues @@ -42,7 +42,7 @@ extra-source-files: test/debug_metadata_4.ll test/debug_metadata_5.ll test/main_return_38.c -tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5 +tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.10.4 extra-source-files: CHANGELOG.md source-repository head @@ -239,7 +239,7 @@ library src/LLVM/Internal/FFI/TypeC.cpp src/LLVM/Internal/FFI/ValueC.cpp - cc-options: -std=c++11 -Wno-stringop-overflow + cc-options: -std=c++11 -Wno-stringop-overflow -Wno-init-list-lifetime if flag(debug) cc-options: -g diff --git a/llvm-hs/src/LLVM/Internal/FFI/Metadata.h b/llvm-hs/src/LLVM/Internal/FFI/Metadata.h index 8afb729c..ea580060 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/Metadata.h +++ b/llvm-hs/src/LLVM/Internal/FFI/Metadata.h @@ -47,27 +47,29 @@ enum LLVM_Hs_DwOp { }; #define LLVM_HS_FOR_EACH_DW_OP(macro) \ - macro(LLVM_fragment) \ - macro(stack_value) \ - macro(swap) \ + macro(and) \ + macro(bregx) \ macro(constu) \ + macro(deref) \ + macro(div) \ + macro(dup) \ macro(lit0) \ - macro(plus_uconst) \ - macro(plus) \ + macro(LLVM_fragment) \ macro(minus) \ - macro(mul) \ - macro(div) \ macro(mod) \ + macro(mul) \ macro(not) \ macro(or) \ - macro(xor) \ - macro(and) \ + macro(plus) \ + macro(plus_uconst) \ + macro(push_object_address) \ + macro(shl) \ macro(shr) \ macro(shra) \ - macro(shl) \ - macro(dup) \ - macro(deref) \ - macro(xderef) + macro(stack_value) \ + macro(swap) \ + macro(xderef) \ + macro(xor) enum LLVM_Hs_DwAtE { #define HANDLE_DW_ATE(ID, NAME, VERSION, VENDOR) LLVM_Hs_DwAtE_##NAME = ID, diff --git a/llvm-hs/src/LLVM/Internal/FFI/OrcJITC.cpp b/llvm-hs/src/LLVM/Internal/FFI/OrcJITC.cpp index d60cbf4e..344fd307 100644 --- a/llvm-hs/src/LLVM/Internal/FFI/OrcJITC.cpp +++ b/llvm-hs/src/LLVM/Internal/FFI/OrcJITC.cpp @@ -336,12 +336,19 @@ JITTargetAddress LLVM_Hs_JITSymbol_getAddress(LLVMJITSymbolRef symbol, char **errorMessage) { *errorMessage = nullptr; if (auto addrOrErr = symbol->getAddress()) { - return *addrOrErr; - } else { - std::string error = toString(addrOrErr.takeError()); - *errorMessage = strdup(error.c_str()); - return 0; + // I think this is a bug in LLVM: getAddress() is meant to return '0' for undefined symbols + // according to https://llvm.org/doxygen/classllvm_1_1JITSymbol.html#a728b38fd41b0dfb04489af84087b8712 + // Reading that more liberally, it should be returning an 'Expect' whose + // 'operator bool()' is false (since there is an error) + // https://llvm.org/doxygen/classllvm_1_1Expected.html#abedc24a1407796eedbee8ba9786d0387 + // However, it clearly is not false since we get in here, and we need to actually + // attempt to get the value out of the 'Expect' before we finally trigger a failure. + if (*addrOrErr) { + return *addrOrErr; + } } + *errorMessage = strdup("undefined symbol"); + return 0; } LLVMJITSymbolFlags LLVM_Hs_JITSymbol_getFlags(LLVMJITSymbolRef symbol) { diff --git a/llvm-hs/src/LLVM/Internal/Operand.hs b/llvm-hs/src/LLVM/Internal/Operand.hs index 5e4f9cb4..e662fa27 100644 --- a/llvm-hs/src/LLVM/Internal/Operand.hs +++ b/llvm-hs/src/LLVM/Internal/Operand.hs @@ -166,32 +166,44 @@ instance DecodeM DecodeAST A.Metadata (Ptr FFI.Metadata) where then A.MDValue <$> decodeM v else throwM (DecodeException "Metadata was not one of [MDString, MDValue, MDNode]") -instance DecodeM DecodeAST A.DINode (Ptr FFI.DINode) where +instance DecodeM DecodeAST (Either String A.DINode) (Ptr FFI.DINode) where decodeM diN = do sId <- liftIO $ FFI.getMetadataClassId (FFI.upCast diN) case sId of [mdSubclassIdP|DIEnumerator|] -> - A.DIEnumerator <$> decodeM (castPtr diN :: Ptr FFI.DIEnumerator) - [mdSubclassIdP|DIImportedEntity|] -> A.DIImportedEntity <$> decodeM (castPtr diN :: Ptr FFI.DIImportedEntity) - [mdSubclassIdP|DIObjCProperty|] -> A.DIObjCProperty <$> decodeM (castPtr diN :: Ptr FFI.DIObjCProperty) - [mdSubclassIdP|DISubrange|] -> A.DISubrange <$> decodeM (castPtr diN :: Ptr FFI.DISubrange) - [mdSubclassIdP|DIBasicType|] -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) - [mdSubclassIdP|DICompositeType|] -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) - [mdSubclassIdP|DIDerivedType|] -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) - [mdSubclassIdP|DISubroutineType|] -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) - [mdSubclassIdP|DILexicalBlock|] -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) - [mdSubclassIdP|DILexicalBlockFile|] -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) - [mdSubclassIdP|DIFile|] -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) - [mdSubclassIdP|DINamespace|] -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) - [mdSubclassIdP|DISubprogram|] -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) - [mdSubclassIdP|DICompileUnit|] -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) - [mdSubclassIdP|DIModule|] -> A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) - - [mdSubclassIdP|DIGlobalVariable|] -> A.DIVariable <$> decodeM (castPtr diN :: Ptr FFI.DIVariable) - [mdSubclassIdP|DILocalVariable|] -> A.DIVariable <$> decodeM (castPtr diN :: Ptr FFI.DIVariable) - - [mdSubclassIdP|DITemplateTypeParameter|] -> A.DITemplateParameter <$> decodeM (castPtr diN :: Ptr FFI.DITemplateParameter) - [mdSubclassIdP|DITemplateValueParameter|] -> A.DITemplateParameter <$> decodeM (castPtr diN :: Ptr FFI.DITemplateParameter) + liftM Right $ A.DIEnumerator <$> decodeM (castPtr diN :: Ptr FFI.DIEnumerator) + [mdSubclassIdP|DIImportedEntity|] -> liftM Right $ A.DIImportedEntity <$> decodeM (castPtr diN :: Ptr FFI.DIImportedEntity) + [mdSubclassIdP|DIObjCProperty|] -> liftM Right $ A.DIObjCProperty <$> decodeM (castPtr diN :: Ptr FFI.DIObjCProperty) + [mdSubclassIdP|DISubrange|] -> liftM Right $ A.DISubrange <$> decodeM (castPtr diN :: Ptr FFI.DISubrange) + [mdSubclassIdP|DIBasicType|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + [mdSubclassIdP|DICompositeType|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + [mdSubclassIdP|DIDerivedType|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + [mdSubclassIdP|DISubroutineType|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + [mdSubclassIdP|DILexicalBlock|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + [mdSubclassIdP|DILexicalBlockFile|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + [mdSubclassIdP|DIFile|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + [mdSubclassIdP|DINamespace|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + [mdSubclassIdP|DISubprogram|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + [mdSubclassIdP|DICompileUnit|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + [mdSubclassIdP|DIModule|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + + [mdSubclassIdP|DIGlobalVariable|] -> liftM Right $ A.DIVariable <$> decodeM (castPtr diN :: Ptr FFI.DIVariable) + [mdSubclassIdP|DILocalVariable|] -> liftM Right $ A.DIVariable <$> decodeM (castPtr diN :: Ptr FFI.DIVariable) + + [mdSubclassIdP|DITemplateTypeParameter|] -> liftM Right $ A.DITemplateParameter <$> decodeM (castPtr diN :: Ptr FFI.DITemplateParameter) + [mdSubclassIdP|DITemplateValueParameter|] -> liftM Right $ A.DITemplateParameter <$> decodeM (castPtr diN :: Ptr FFI.DITemplateParameter) + + [mdSubclassIdP|MDString|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (MDString)") + [mdSubclassIdP|ConstantAsMetadata|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (ConstantAsMetadata)") + [mdSubclassIdP|LocalAsMetadata|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (LocalAsMetadata)") + [mdSubclassIdP|DistinctMDOperandPlaceholder|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DistinctMDOperandPlaceholder)") + [mdSubclassIdP|MDTuple|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (MDTuple)") + [mdSubclassIdP|DILocation|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DILocation)") + [mdSubclassIdP|DIExpression|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DIExpression)") + [mdSubclassIdP|DIGlobalVariableExpression|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DIGlobalVariableExpression)") + [mdSubclassIdP|GenericDINode|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (GenericDINode)") + [mdSubclassIdP|DIMacro|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DIMacro)") + [mdSubclassIdP|DIMacroFile|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DIMacroFile)") _ -> throwM (DecodeException ("Unknown subclass id for DINode: " <> show sId)) @@ -769,7 +781,7 @@ 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 {} -> + A.DITemplateTypeParameter {} -> FFI.upCast <$> liftIO (FFI.getDITemplateTypeParameter c name' ty) A.DITemplateValueParameter {..} -> do tag <- encodeM tag @@ -1000,27 +1012,29 @@ instance (MonadIO m, MonadAnyCont IO m, DecodeM m a (Ptr a')) => DecodeM m [a] ( encodeDWOp :: A.DWOp -> [Word64] encodeDWOp op = case op of - A.DwOpFragment (A.DW_OP_LLVM_Fragment offset size) -> [FFI.DwOp_LLVM_fragment, offset, size] - A.DW_OP_StackValue -> [FFI.DwOp_stack_value] - A.DW_OP_Swap -> [FFI.DwOp_swap] + A.DW_OP_And -> [FFI.DwOp_and] + A.DW_OP_Bregx -> [FFI.DwOp_bregx] A.DW_OP_ConstU arg -> [FFI.DwOp_constu, arg] + A.DW_OP_Deref -> [FFI.DwOp_deref] + A.DW_OP_Div -> [FFI.DwOp_div] + A.DW_OP_Dup -> [FFI.DwOp_dup] + A.DwOpFragment (A.DW_OP_LLVM_Fragment offset size) -> [FFI.DwOp_LLVM_fragment, offset, size] A.DW_OP_Lit0 -> [FFI.DwOp_lit0] - A.DW_OP_PlusUConst arg -> [FFI.DwOp_plus_uconst, arg] - A.DW_OP_Plus -> [FFI.DwOp_plus] A.DW_OP_Minus -> [FFI.DwOp_minus] - A.DW_OP_Mul -> [FFI.DwOp_mul] - A.DW_OP_Div -> [FFI.DwOp_div] A.DW_OP_Mod -> [FFI.DwOp_mod] + A.DW_OP_Mul -> [FFI.DwOp_mul] A.DW_OP_Not -> [FFI.DwOp_not] A.DW_OP_Or -> [FFI.DwOp_or] - A.DW_OP_Xor -> [FFI.DwOp_xor] - A.DW_OP_And -> [FFI.DwOp_and] - A.DW_OP_Shr -> [FFI.DwOp_shr] - A.DW_OP_Shra -> [FFI.DwOp_shra] + A.DW_OP_Plus -> [FFI.DwOp_plus] + A.DW_OP_PlusUConst arg -> [FFI.DwOp_plus_uconst, arg] + A.DW_OP_PushObjectAddress -> [FFI.DwOp_push_object_address] A.DW_OP_Shl -> [FFI.DwOp_shl] - A.DW_OP_Dup -> [FFI.DwOp_dup] - A.DW_OP_Deref -> [FFI.DwOp_deref] + A.DW_OP_Shra -> [FFI.DwOp_shra] + A.DW_OP_Shr -> [FFI.DwOp_shr] + A.DW_OP_StackValue -> [FFI.DwOp_stack_value] + A.DW_OP_Swap -> [FFI.DwOp_swap] A.DW_OP_XDeref -> [FFI.DwOp_xderef] + A.DW_OP_Xor -> [FFI.DwOp_xor] instance DecodeM DecodeAST [Maybe A.Metadata] (Ptr FFI.MDNode) where decodeM p = decodeArray FFI.getMDNodeNumOperands FFI.getMDNodeOperand p @@ -1033,19 +1047,23 @@ instance DecodeM DecodeAST A.Metadata (Ptr FFI.MetadataAsVal) where genCodingInstance [t|A.DIMacroInfo|] ''FFI.Macinfo [ (FFI.DW_Macinfo_Define, A.Define), (FFI.DW_Macinfo_Undef, A.Undef) ] -decodeMDNode :: Ptr FFI.MDNode -> DecodeAST A.MDNode +decodeMDNode :: Ptr FFI.MDNode -> DecodeAST (Either String A.MDNode) decodeMDNode p = scopeAnyCont $ do sId <- liftIO $ FFI.getMetadataClassId p case sId of - [mdSubclassIdP|MDTuple|] -> A.MDTuple <$> decodeM p + [mdSubclassIdP|MDTuple|] -> liftM Right $ A.MDTuple <$> decodeM p [mdSubclassIdP|DIExpression|] -> - A.DIExpression <$> decodeM (castPtr p :: Ptr FFI.DIExpression) + liftM Right $ A.DIExpression <$> decodeM (castPtr p :: Ptr FFI.DIExpression) [mdSubclassIdP|DIGlobalVariableExpression|] -> - A.DIGlobalVariableExpression <$> decodeM (castPtr p :: Ptr FFI.DIGlobalVariableExpression) - [mdSubclassIdP|DILocation|] -> A.DILocation <$> decodeM (castPtr p :: Ptr FFI.DILocation) - [mdSubclassIdP|DIMacro|] -> A.DIMacroNode <$> decodeM (castPtr p :: Ptr FFI.DIMacroNode) - [mdSubclassIdP|DIMacroFile|] -> A.DIMacroNode <$> decodeM (castPtr p :: Ptr FFI.DIMacroNode) - _ -> A.DINode <$> decodeM (castPtr p :: Ptr FFI.DINode) + liftM Right $ A.DIGlobalVariableExpression <$> decodeM (castPtr p :: Ptr FFI.DIGlobalVariableExpression) + [mdSubclassIdP|DILocation|] -> liftM Right $ A.DILocation <$> decodeM (castPtr p :: Ptr FFI.DILocation) + [mdSubclassIdP|DIMacro|] -> liftM Right $ A.DIMacroNode <$> decodeM (castPtr p :: Ptr FFI.DIMacroNode) + [mdSubclassIdP|DIMacroFile|] -> liftM Right $ A.DIMacroNode <$> decodeM (castPtr p :: Ptr FFI.DIMacroNode) + _ -> do + decoded <- decodeM (castPtr p :: Ptr FFI.DINode) + case decoded of + (Right din) -> liftM Right $ pure $ A.DINode din + (Left err) -> pure $ Left err instance DecodeM DecodeAST A.DIMacroNode (Ptr FFI.DIMacroNode) where decodeM p = do @@ -1124,6 +1142,8 @@ instance DecodeM DecodeAST A.DIExpression (Ptr FFI.DIExpression) where FFI.DwOp_dup -> (A.DW_OP_Dup :) <$> go (i + 1) FFI.DwOp_deref -> (A.DW_OP_Deref :) <$> go (i + 1) FFI.DwOp_xderef -> (A.DW_OP_XDeref :) <$> go (i + 1) + FFI.DwOp_bregx -> (A.DW_OP_Bregx :) <$> go (i + 1) + FFI.DwOp_push_object_address -> (A.DW_OP_PushObjectAddress :) <$> go (i + 1) _ -> throwM (DecodeException ("Unknown DW_OP " <> show op)) expectElems name i n = when (i + n >= numElems) @@ -1163,11 +1183,13 @@ instance DecodeM DecodeAST A.DIImportedEntity (Ptr FFI.DIImportedEntity) where decodeM e = do tag <- decodeM =<< liftIO (FFI.getTag (FFI.upCast e)) scope <- decodeM =<< liftIO (FFI.getDIImportedEntityScope e) - entity <- decodeM =<< liftIO (FFI.getDIImportedEntityEntity e) + entity :: Either String A.DINode <- decodeM =<< liftIO (FFI.getDIImportedEntityEntity e) file <- decodeM =<< liftIO (FFI.getDIImportedEntityFile e) name <- decodeM =<< liftIO (FFI.getDIImportedEntityName e) line <- liftIO (FFI.getDIImportedEntityLine e) - pure (A.ImportedEntity tag name scope entity file line) + case entity of + (Right din) -> pure (A.ImportedEntity tag name scope (Just $ A.MDInline din) file line) + (Left _) -> pure (A.ImportedEntity tag name scope Nothing file line) instance EncodeM EncodeAST A.DIObjCProperty (Ptr FFI.DIObjCProperty) where encodeM A.ObjCProperty {..} = do @@ -1210,7 +1232,11 @@ getMetadataDefinitions = fix $ \continue -> do mdntd <- takeMetadataNodeToDefine case mdntd of Nothing -> pure [] - Just (mid, p) -> - (:) - <$> (A.MetadataNodeDefinition mid <$> decodeMDNode p) - <*> continue + Just (mid, p) -> do + decoded <- decodeMDNode p + case decoded of + (Right mdn) -> + (:) + <$> (pure $ A.MetadataNodeDefinition mid mdn) + <*> continue + (Left _) -> continue diff --git a/llvm-hs/src/LLVM/Internal/OrcJIT.hs b/llvm-hs/src/LLVM/Internal/OrcJIT.hs index d37f2d70..06625deb 100644 --- a/llvm-hs/src/LLVM/Internal/OrcJIT.hs +++ b/llvm-hs/src/LLVM/Internal/OrcJIT.hs @@ -114,8 +114,8 @@ instance (MonadIO m, MonadAnyCont IO m) => DecodeM m (Either JITSymbolError JITS rawFlags <- liftIO (FFI.getFlags jitSymbol) if addr == 0 || (rawFlags .&. FFI.jitSymbolFlagsHasError /= 0) then do - errMsg <- decodeM =<< liftIO (FFI.getErrorMsg jitSymbol) - pure (Left (JITSymbolError errMsg)) + errMsg' <- decodeM errMsg + pure (Left (JITSymbolError errMsg')) else do flags <- decodeM rawFlags pure (Right (JITSymbol (fromIntegral addr) flags)) diff --git a/llvm-hs/test/LLVM/Test/Metadata.hs b/llvm-hs/test/LLVM/Test/Metadata.hs index b78eecea..151d0ad2 100644 --- a/llvm-hs/test/LLVM/Test/Metadata.hs +++ b/llvm-hs/test/LLVM/Test/Metadata.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module LLVM.Test.Metadata where import LLVM.Prelude @@ -346,8 +347,8 @@ roundtripDINode :: TestTree roundtripDINode = testProperty "roundtrip DINode" $ \diNode -> ioProperty $ withContext $ \context -> runEncodeAST context $ do encodedDINode <- encodeM (diNode :: DINode) - decodedDINode <- liftIO (runDecodeAST (decodeM (encodedDINode :: Ptr FFI.DINode))) - pure (decodedDINode === diNode) + decodedDINode :: Either String DINode <- liftIO (runDecodeAST (decodeM (encodedDINode :: Ptr FFI.DINode))) + pure (decodedDINode === (Right diNode)) roundtripDICompileUnit :: TestTree roundtripDICompileUnit = testProperty "roundtrip DICompileUnit" $ \diFile retainedType -> diff --git a/llvm-hs/test/LLVM/Test/OrcJIT.hs b/llvm-hs/test/LLVM/Test/OrcJIT.hs index b880705b..275dc494 100644 --- a/llvm-hs/test/LLVM/Test/OrcJIT.hs +++ b/llvm-hs/test/LLVM/Test/OrcJIT.hs @@ -79,6 +79,9 @@ resolver testFunc compileLayer symbol = do nullResolver :: MangledSymbol -> IO (Either JITSymbolError JITSymbol) nullResolver s = putStrLn "nullresolver" >> return (Left (JITSymbolError "unknown symbol")) +simpleResolver :: CompileLayer l => l -> MangledSymbol -> IO (Either JITSymbolError JITSymbol) +simpleResolver compileLayer symbol = CL.findSymbol compileLayer symbol True + moduleTransform :: IORef Bool -> Ptr FFI.Module -> IO (Ptr FFI.Module) moduleTransform passmanagerSuccessful modulePtr = do withPassManager defaultCuratedPassSetSpec { optLevel = Just 2 } $ \(PassManager pm) -> do @@ -110,7 +113,7 @@ tests = result @?= 42 unknownSymbol <- mangleSymbol compileLayer "unknownSymbol" unknownSymbolRes <- CL.findSymbol compileLayer unknownSymbol True - unknownSymbolRes @?= Left (JITSymbolError mempty), + unknownSymbolRes @?= Left (JITSymbolError "undefined symbol"), testCase "IRTransformLayer" $ do passmanagerSuccessful <- newIORef False diff --git a/stack.yaml b/stack.yaml index 9d7f92aa..c12b4d4b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2020-01-30 +resolver: lts-17.12 packages: - llvm-hs @@ -6,3 +6,5 @@ packages: extra-package-dbs: [] +ghc-options: + llvm-hs: -optcxx=-std=c++11 -optcxx=-lstdc++ -optcxx=-fno-rtti -optcxx=-Wno-init-list-lifetime -optcxx=-Wno-stringop-overflow 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