diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,20 @@ +## 7.0.0 (2018-09-28) + +* Track type definitions in `MonadModuleBuilder`. This allows us to + automatically resolve `NamedTypeReference`s in `gep` instructions. + Note that type definitions must be defined before they are used + (i.e. `MonadFix` will not behave correctly here). +* Change the type of `gep` in the `IRBuilder` API to require a + `MonadModuleBuilder` constraint. +* Change the type of `typedef` in the `IRBuilder` API to return a + `NamedTypeReference` to the newly defined type. +* Update for LLVM 7.0: + * Add `isUnsigned` field to `DIEnumerator`. + * Change `DISubrange` to use the new `DICount` type instead of an `Int64`. + * Merge `checksum` and `checksumKind` fields of `DIFile` into a + `checksum` field of type `Maybe ChecksumInfo`. + * Rename the `variables` field of `DISubprogram` to `retainedNodes`. + ## 6.2.1 (2018-06-12) * Fix type of `shuffleVector` in the IRBuilder API. diff --git a/llvm-hs-pure.cabal b/llvm-hs-pure.cabal --- a/llvm-hs-pure.cabal +++ b/llvm-hs-pure.cabal @@ -1,5 +1,5 @@ name: llvm-hs-pure -version: 6.2.1 +version: 7.0.0 license: BSD3 license-file: LICENSE author: Anthony Cowley, Stephen Diehl, Moritz Kiefer , Benjamin S. Scarlet @@ -22,7 +22,7 @@ source-repository head type: git location: git://github.com/llvm-hs/llvm-hs.git - branch: llvm-5 + branch: llvm-7 library default-language: Haskell2010 diff --git a/src/LLVM/AST/Operand.hs b/src/LLVM/AST/Operand.hs --- a/src/LLVM/AST/Operand.hs +++ b/src/LLVM/AST/Operand.hs @@ -195,14 +195,19 @@ -- | data DIEnumerator = - Enumerator { value :: Int64, name :: ShortByteString } + Enumerator { value :: Int64, isUnsigned :: Bool, name :: ShortByteString } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- | data DISubrange = - Subrange { count :: Int64, lowerBound :: Int64 } + Subrange { count :: DICount, lowerBound :: Int64 } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data DICount + = DICountConstant Int64 + | DICountVariable (MDRef DIVariable) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + -- | data DIScope = DICompileUnit DICompileUnit @@ -255,11 +260,15 @@ data DIFile = File { filename :: ShortByteString , directory :: ShortByteString - , checksum :: ShortByteString - , checksumKind :: ChecksumKind + , checksum :: Maybe ChecksumInfo } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data ChecksumKind = None | MD5 | SHA1 +data ChecksumInfo = ChecksumInfo + { checksumKind :: ChecksumKind + , checksumValue :: ShortByteString + } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data ChecksumKind = MD5 | SHA1 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- | @@ -288,7 +297,7 @@ , unit :: Maybe (MDRef DICompileUnit) , templateParams :: [MDRef DITemplateParameter] , declaration :: Maybe (MDRef DISubprogram) - , variables :: [MDRef DILocalVariable] + , retainedNodes :: [MDRef DILocalVariable] , thrownTypes :: [MDRef DIType] } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) diff --git a/src/LLVM/IRBuilder/Instruction.hs b/src/LLVM/IRBuilder/Instruction.hs --- a/src/LLVM/IRBuilder/Instruction.hs +++ b/src/LLVM/IRBuilder/Instruction.hs @@ -4,6 +4,8 @@ import Prelude hiding (and, or, pred) +import Control.Monad.State (gets) +import qualified Data.Map.Lazy as Map import Data.Word import LLVM.AST hiding (args, dests) @@ -17,6 +19,7 @@ import qualified LLVM.AST.FloatingPointPredicate as FP import LLVM.IRBuilder.Monad +import LLVM.IRBuilder.Module fadd :: MonadIRBuilder m => Operand -> Operand -> m Operand fadd a b = emitInstr (typeOf a) $ FAdd noFastMathFlags a b [] @@ -82,18 +85,25 @@ store :: MonadIRBuilder m => Operand -> Word32 -> Operand -> m () store addr align val = emitInstrVoid $ Store False addr val Nothing align [] -gep :: MonadIRBuilder m => Operand -> [Operand] -> m Operand -gep addr is = emitInstr (gepType (typeOf addr) is) (GetElementPtr False addr is []) +gep :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> [Operand] -> m Operand +gep addr is = do + ty <- gepType (typeOf addr) is + emitInstr ty (GetElementPtr False addr is []) where -- TODO: Perhaps use the function from llvm-hs-pretty (https://github.com/llvm-hs/llvm-hs-pretty/blob/master/src/LLVM/Typed.hs) - gepType :: Type -> [Operand] -> Type - gepType ty [] = ptr ty + gepType :: MonadModuleBuilder m => Type -> [Operand] -> m Type + gepType ty [] = pure (ptr ty) gepType (PointerType ty _) (_:is') = gepType ty is' gepType (StructureType _ elTys) (ConstantOperand (C.Int 32 val):is') = gepType (elTys !! fromIntegral val) is' gepType (StructureType _ _) (i:_) = error $ "gep: Indices into structures should be 32-bit constants. " ++ show i gepType (VectorType _ elTy) (_:is') = gepType elTy is' gepType (ArrayType _ elTy) (_:is') = gepType elTy is' + gepType (NamedTypeReference nm) is' = do + mayTy <- liftModuleState (gets (Map.lookup nm . builderTypeDefs)) + case mayTy of + Nothing -> error $ "gep: Couldn’t resolve typedef for: " ++ show nm + Just ty -> gepType ty is' gepType t (_:_) = error $ "gep: Can't index into a " ++ show t trunc :: MonadIRBuilder m => Operand -> Type -> m Operand diff --git a/src/LLVM/IRBuilder/Module.hs b/src/LLVM/IRBuilder/Module.hs --- a/src/LLVM/IRBuilder/Module.hs +++ b/src/LLVM/IRBuilder/Module.hs @@ -36,6 +36,9 @@ import Data.ByteString.Short as BS import Data.Char import Data.Data +import Data.Foldable +import Data.Map.Lazy (Map) +import qualified Data.Map.Lazy as Map import Data.String import GHC.Generics(Generic) @@ -44,6 +47,7 @@ import LLVM.AST.Global import LLVM.AST.Linkage import LLVM.AST.Type (ptr) +import qualified LLVM.AST.Typed import qualified LLVM.AST.Constant as C import LLVM.IRBuilder.Internal.SnocList @@ -58,13 +62,15 @@ instance MonadFail m => MonadFail (ModuleBuilderT m) where fail str = ModuleBuilderT (StateT $ \_ -> Fail.fail str) -newtype ModuleBuilderState = ModuleBuilderState +data ModuleBuilderState = ModuleBuilderState { builderDefs :: SnocList Definition + , builderTypeDefs :: Map Name Type } emptyModuleBuilder :: ModuleBuilderState emptyModuleBuilder = ModuleBuilderState { builderDefs = mempty + , builderTypeDefs = mempty } type ModuleBuilder = ModuleBuilderT Identity @@ -81,6 +87,8 @@ instance Monad m => MonadModuleBuilder (ModuleBuilderT m) where liftModuleState (StateT s) = ModuleBuilderT $ StateT $ pure . runIdentity . s + + -- | Evaluate 'ModuleBuilder' to a result and a list of definitions runModuleBuilder :: ModuleBuilderState -> ModuleBuilder a -> (a, [Definition]) runModuleBuilder s m = runIdentity $ runModuleBuilderT s m @@ -160,15 +168,73 @@ let funty = ptr $ FunctionType retty argtys False pure $ ConstantOperand $ C.GlobalReference funty nm +-- | An external variadic argument function definition +externVarArgs + :: MonadModuleBuilder m + => Name -- ^ Definition name + -> [Type] -- ^ Parameter types + -> Type -- ^ Type + -> m Operand +externVarArgs nm argtys retty = do + emitDefn $ GlobalDefinition functionDefaults + { name = nm + , linkage = External + , parameters = ([Parameter ty (mkName "") [] | ty <- argtys], True) + , returnType = retty + } + let funty = ptr $ FunctionType retty argtys True + pure $ ConstantOperand $ C.GlobalReference funty nm + +-- | A global variable definition +global + :: MonadModuleBuilder m + => Name -- ^ Variable name + -> Type -- ^ Type + -> C.Constant -- ^ Initializer + -> m Operand +global nm ty initVal = do + emitDefn $ GlobalDefinition globalVariableDefaults + { name = nm + , LLVM.AST.Global.type' = ty + , linkage = External + , initializer = Just initVal + } + pure $ ConstantOperand $ C.GlobalReference (ptr ty) nm + +-- | 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 + => String -- ^ The string to generate + -> Name -- ^ Variable name of the pointer + -> m Operand +globalStringPtr str nm = do + let asciiVals = map (fromIntegral . ord) str + llvmVals = map (C.Int 8) (asciiVals ++ [0]) -- append null terminator + char = IntegerType 8 + charStar = ptr char + charArray = C.Array char llvmVals + emitDefn $ GlobalDefinition globalVariableDefaults + { name = nm + , LLVM.AST.Global.type' = LLVM.AST.Typed.typeOf charArray + , linkage = External + , isConstant = True + , initializer = Just charArray + , unnamedAddr = Just GlobalAddr + } + pure $ ConstantOperand $ C.BitCast (C.GlobalReference charStar nm) charStar + -- | A named type definition typedef :: MonadModuleBuilder m => Name -> Maybe Type - -> m () + -> m Type typedef nm ty = do emitDefn $ TypeDefinition nm ty - pure () + for_ ty $ \ty' -> + liftModuleState (modify (\s -> s { builderTypeDefs = Map.insert nm ty' (builderTypeDefs s) })) + pure (NamedTypeReference nm) -- | Convenience function for module construction buildModule :: ShortByteString -> ModuleBuilder a -> Module @@ -200,4 +266,6 @@ instance MonadModuleBuilder m => MonadModuleBuilder (StateT s m) instance MonadModuleBuilder m => MonadModuleBuilder (Strict.StateT s m) instance (Monoid w, MonadModuleBuilder m) => MonadModuleBuilder (Strict.WriterT w m) -instance (Monoid w, MonadModuleBuilder m) => MonadModuleBuilder (Lazy.WriterT w m) + +-- Not an mtl instance, but necessary in order for @globalStringPtr@ to compile +instance MonadModuleBuilder m => MonadModuleBuilder (IRBuilderT m) diff --git a/src/LLVM/IRBuilder/Monad.hs b/src/LLVM/IRBuilder/Monad.hs --- a/src/LLVM/IRBuilder/Monad.hs +++ b/src/LLVM/IRBuilder/Monad.hs @@ -262,6 +262,18 @@ Just n -> pure n Nothing -> error "Called currentBlock when no block was active" +-- | Find out if the currently active block has a terminator. +-- +-- This function will fail under the same condition as @currentBlock@ +hasTerminator :: MonadIRBuilder m => m Bool +hasTerminator = do + current <- liftIRState $ gets builderBlock + case current of + Nothing -> error "Called hasTerminator when no block was active" + Just blk -> case partialBlockTerm blk of + Nothing -> return False + Just _ -> return True + ------------------------------------------------------------------------------- -- mtl instances ------------------------------------------------------------------------------- diff --git a/test/LLVM/Test/IRBuilder.hs b/test/LLVM/Test/IRBuilder.hs --- a/test/LLVM/Test/IRBuilder.hs +++ b/test/LLVM/Test/IRBuilder.hs @@ -52,6 +52,7 @@ } , testCase "calls constant globals" callWorksWithConstantGlobals , testCase "supports recursive function calls" recursiveFunctionCalls + , testCase "resolves typefes" resolvesTypeDefs , testCase "builds the example" $ do let f10 = ConstantOperand (C.Float (F.Double 10)) fadd a b = FAdd { operand0 = a, operand1 = b, fastMathFlags = noFastMathFlags, metadata = [] } @@ -240,6 +241,64 @@ } ] } + +resolvesTypeDefs :: Assertion +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)] + store xPtr 0 x + store yPtr 0 y + pure () + ast = defaultModule + { moduleName = "" + , moduleDefinitions = + [ TypeDefinition "pair" (Just (StructureType False [AST.i32, AST.i32])) + , GlobalDefinition functionDefaults + { name = "f" + , parameters = ( [ Parameter (AST.ptr (NamedTypeReference "pair")) "ptr" [] + , Parameter AST.i32 "x" [] + , Parameter AST.i32 "y" []] + , False) + , returnType = AST.void + , basicBlocks = + [ BasicBlock (UnName 0) + [ UnName 1 := GetElementPtr + { inBounds = False + , address = LocalReference (AST.ptr (NamedTypeReference "pair")) "ptr" + , indices = [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] + , metadata = [] + } + , UnName 2 := GetElementPtr + { inBounds = False + , address = LocalReference (AST.ptr (NamedTypeReference "pair")) "ptr" + , 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" + , maybeAtomicity = Nothing + , alignment = 0 + , metadata = [] + } + , Do $ Store + { volatile = False + , address = LocalReference (AST.ptr AST.i32) (UnName 2) + , value = LocalReference AST.i32 "y" + , maybeAtomicity = Nothing + , alignment = 0 + , metadata = [] + } + ] + (Do (Ret Nothing [])) + ] + } + ]} simple :: Module simple = buildModule "exampleModule" $ mdo