llvm-hs-pure 5.1.0 → 5.1.1

raw patch · 10 files changed

+1095/−2 lines, 10 filesdep +faildep +hspecdep +textdep ~basedep ~bytestringdep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: fail, hspec, text, unordered-containers

Dependency ranges changed: base, bytestring, containers, mtl, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• llvm-hs-pure.cabal +27/−2
• src/LLVM/AST/Typed.hs +132/−0
• src/LLVM/IRBuilder.hs +8/−0
• src/LLVM/IRBuilder/Constant.hs +35/−0
• src/LLVM/IRBuilder/Instruction.hs +181/−0
• src/LLVM/IRBuilder/Internal/SnocList.hs +16/−0
• src/LLVM/IRBuilder/Module.hs +199/−0
• src/LLVM/IRBuilder/Monad.hs +251/−0
• test/IRBuilder.hs +239/−0

@@ -1,3 +1,10 @@+## 5.1.1 (2017-12-26)++* Add a completely new API for building modules in a monadic style similar to the IRBuilder provided by LLVM’s C++ API. The modules can be found in `LLVM.IRBuilder`. An example can be found in the readme and in the test suite.+* Add an API for getting the type of LLVM values in+  `LLVM.AST.Typed`. This is primarily intended to be used in other+  libraries that build upon `llvm-hs-pure` such as `llvm-hs-pretty`.+ ## 5.1.0 (2017-10-12)  ### Enhancements

@@ -1,5 +1,5 @@ name: llvm-hs-pure-version: 5.1.0+version: 5.1.1 license: BSD3 license-file: LICENSE author: Anthony Cowley, Stephen Diehl, Moritz Kiefer <moritz.kiefer@purelyfunctional.org>, Benjamin S. Scarlet@@ -40,10 +40,12 @@   build-depends:     attoparsec >= 0.13,     bytestring >= 0.10 && < 0.11,+    fail,     transformers >= 0.3 && < 0.6,     mtl >= 2.1,     template-haskell >= 2.5.0.0,-    containers >= 0.4.2.1+    containers >= 0.4.2.1,+    unordered-containers >= 0.2   hs-source-dirs: src   extensions:     NoImplicitPrelude@@ -76,10 +78,17 @@     LLVM.AST.RMWOperation     LLVM.AST.ThreadLocalStorage     LLVM.AST.Type+    LLVM.AST.Typed     LLVM.AST.Visibility     LLVM.AST.DLL     LLVM.AST.COMDAT     LLVM.DataLayout+    LLVM.IRBuilder+    LLVM.IRBuilder.Constant+    LLVM.IRBuilder.Instruction+    LLVM.IRBuilder.Internal.SnocList+    LLVM.IRBuilder.Module+    LLVM.IRBuilder.Monad     LLVM.Prelude  test-suite test@@ -108,3 +117,19 @@   other-modules:     LLVM.Test.DataLayout     LLVM.Test.Tests++test-suite test-irbuilder+  type: exitcode-stdio-1.0+  main-is: IRBuilder.hs+  hs-source-dirs:+      test+  build-depends:+      base >=4.8 && <4.11+    , bytestring+    , containers+    , hspec+    , llvm-hs-pure+    , mtl+    , text+    , transformers+    , unordered-containers

@@ -0,0 +1,132 @@+{-# LANGUAGE RecordWildCards #-}++-- | Querying the type of LLVM expressions+module LLVM.AST.Typed (+  Typed(..),+  getElementType,+  getElementPtrType,+  extractValueType,+) where++import LLVM.Prelude++import LLVM.AST+import LLVM.AST.Global+import LLVM.AST.Type++import qualified LLVM.AST.Constant as C+import qualified LLVM.AST.Float as F++class Typed a where+    typeOf :: a -> Type++instance Typed Operand where+  typeOf (LocalReference t _) = t+  typeOf (ConstantOperand c)  = typeOf c+  typeOf _                    = MetadataType++instance Typed CallableOperand where+  typeOf (Right op) = typeOf op+  typeOf (Left _) = error "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.Struct {..}) = StructureType isPacked (map typeOf memberValues)+  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+  typeOf (C.Add {..})     = typeOf operand0+  typeOf (C.FAdd {..})    = typeOf operand0+  typeOf (C.FDiv {..})    = typeOf operand0+  typeOf (C.FRem {..})    = typeOf operand0+  typeOf (C.Sub {..})     = typeOf operand0+  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+  typeOf (C.LShr {..})    = typeOf operand0+  typeOf (C.AShr {..})    = typeOf operand0+  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.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.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+extractValueType (i : is) (ArrayType numEls elTy)+  | fromIntegral i < numEls = extractValueType is elTy+  | fromIntegral i >= numEls = error "Expecting valid index into array type. (Malformed AST)"+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)"++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++instance Typed Global where+  typeOf (GlobalVariable {..}) = type'+  typeOf (GlobalAlias {..})    = type'+  typeOf (Function {..})       = let (params, isVarArg) = parameters+                                   in FunctionType returnType (map typeOf params) isVarArg+instance Typed Parameter where+  typeOf (Parameter t _ _) = t

@@ -0,0 +1,8 @@+module LLVM.IRBuilder+  (module X)+  where++import LLVM.IRBuilder.Monad as X+import LLVM.IRBuilder.Instruction as X+import LLVM.IRBuilder.Module as X+import LLVM.IRBuilder.Constant as X

@@ -0,0 +1,35 @@+module LLVM.IRBuilder.Constant where+import           Data.Word+import           LLVM.Prelude+import           LLVM.AST             hiding (args, dests)+import qualified LLVM.AST.Constant    as C+import           LLVM.AST.Type        as AST+import           LLVM.AST.Typed+import           LLVM.IRBuilder.Monad++import           LLVM.AST.Constant+import           LLVM.AST.Float++int64 :: Applicative f => Integer -> f Operand+int64 = pure . ConstantOperand . Int 64++int32 :: Applicative f => Integer -> f Operand+int32 = pure . ConstantOperand . Int 32++bit :: Applicative f => Integer -> f Operand+bit = pure . ConstantOperand . Int 1++double :: Applicative f => Double -> f Operand+double = pure . ConstantOperand . Float . Double++single :: Applicative f => Float -> f Operand+single = pure . ConstantOperand . Float . Single++half :: Applicative f => Word16 -> f Operand+half = pure . ConstantOperand . Float . Half++struct :: Applicative f => Maybe Name -> Bool -> [Constant] -> f Operand+struct nm packing members = pure . ConstantOperand $ Struct nm packing members++array :: Applicative f => [Constant] -> f Operand+array members = pure . ConstantOperand $ Array (typeOf $ head members) members

@@ -0,0 +1,181 @@+{-# LANGUAGE FlexibleContexts #-}++module LLVM.IRBuilder.Instruction where++import Prelude hiding (and, or, pred)++import Data.Word++import LLVM.AST hiding (args, dests)+import LLVM.AST.Type as AST+import LLVM.AST.Typed+import LLVM.AST.ParameterAttribute+import qualified LLVM.AST as AST+import qualified LLVM.AST.CallingConvention as CC+import qualified LLVM.AST.Constant as C+import qualified LLVM.AST.IntegerPredicate as IP+import qualified LLVM.AST.FloatingPointPredicate as FP++import LLVM.IRBuilder.Monad++fadd :: MonadIRBuilder m => Operand -> Operand -> m Operand+fadd a b = emitInstr (typeOf a) $ FAdd NoFastMathFlags a b []++fmul :: MonadIRBuilder m => Operand -> Operand -> m Operand+fmul a b = emitInstr (typeOf a) $ FMul NoFastMathFlags a b []++fsub :: MonadIRBuilder m => Operand -> Operand -> m Operand+fsub a b = emitInstr (typeOf a) $ FSub NoFastMathFlags a b []++fdiv :: MonadIRBuilder m => Operand -> Operand -> m Operand+fdiv a b = emitInstr (typeOf a) $ FDiv NoFastMathFlags a b []++frem :: MonadIRBuilder m => Operand -> Operand -> m Operand+frem a b = emitInstr (typeOf a) $ FRem NoFastMathFlags a b []++add :: MonadIRBuilder m => Operand -> Operand -> m Operand+add a b = emitInstr (typeOf a) $ Add False False a b []++mul :: MonadIRBuilder m => Operand -> Operand -> m Operand+mul a b = emitInstr (typeOf a) $ Mul False False a b []++sub :: MonadIRBuilder m => Operand -> Operand -> m Operand+sub a b = emitInstr (typeOf a) $ Sub False False a b []++udiv :: MonadIRBuilder m => Operand -> Operand -> m Operand+udiv a b = emitInstr (typeOf a) $ UDiv True a b []++sdiv :: MonadIRBuilder m => Operand -> Operand -> m Operand+sdiv a b = emitInstr (typeOf a) $ SDiv True a b []++urem :: MonadIRBuilder m => Operand -> Operand -> m Operand+urem a b = emitInstr (typeOf a) $ URem a b []++shl :: MonadIRBuilder m => Operand -> Operand -> m Operand+shl a b = emitInstr (typeOf a) $ Shl False False a b []++lshr :: MonadIRBuilder m => Operand -> Operand -> m Operand+lshr a b = emitInstr (typeOf a) $ LShr True a b []++ashr :: MonadIRBuilder m => Operand -> Operand -> m Operand+ashr a b = emitInstr (typeOf a) $ AShr True a b []++and :: MonadIRBuilder m => Operand -> Operand -> m Operand+and a b = emitInstr (typeOf a) $ And a b []++or :: MonadIRBuilder m => Operand -> Operand -> m Operand+or a b = emitInstr (typeOf a) $ Or a b []++xor :: MonadIRBuilder m => Operand -> Operand -> m Operand+xor a b = emitInstr (typeOf a) $ Xor a b []++alloca :: MonadIRBuilder m => Type -> Maybe Operand -> Word32 -> m Operand+alloca ty count align = emitInstr (ptr ty) $ Alloca ty count align []++load :: 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)."++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 [])+  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 (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 t (_:_) = error $ "gep: Can't index into a " ++ show t++trunc :: MonadIRBuilder m => Operand -> Type -> m Operand+trunc a to = emitInstr to $ Trunc a to []++zext :: MonadIRBuilder m => Operand -> Type -> m Operand+zext a to = emitInstr to $ ZExt a to []++sext :: MonadIRBuilder m => Operand -> Type -> m Operand+sext a to = emitInstr to $ SExt a to []++fptoui :: MonadIRBuilder m => Operand -> Type -> m Operand+fptoui a to = emitInstr to $ FPToUI a to []++fptosi :: MonadIRBuilder m => Operand -> Type -> m Operand+fptosi a to = emitInstr to $ FPToSI a to []++uitofp :: MonadIRBuilder m => Operand -> Type -> m Operand+uitofp a to = emitInstr to $ UIToFP a to []++sitofp :: MonadIRBuilder m => Operand -> Type -> m Operand+sitofp a to = emitInstr to $ SIToFP a to []++ptrtoint :: MonadIRBuilder m => Operand -> Type -> m Operand+ptrtoint a to = emitInstr to $ PtrToInt a to []++inttoptr :: MonadIRBuilder m => Operand -> Type -> m Operand+inttoptr a to = emitInstr to $ IntToPtr a to []++bitcast :: MonadIRBuilder m => Operand -> Type -> m Operand+bitcast a to = emitInstr to $ BitCast a to []++icmp :: MonadIRBuilder m => IP.IntegerPredicate -> Operand -> Operand -> m Operand+icmp pred a b = emitInstr i1 $ ICmp pred a b []++fcmp :: MonadIRBuilder m => FP.FloatingPointPredicate -> Operand -> Operand -> m Operand+fcmp pred a b = emitInstr i1 $ FCmp pred a b []++-- | Unconditional branch+br :: MonadIRBuilder m => Name -> m ()+br val = emitTerm (Br val [])++phi :: MonadIRBuilder 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++retVoid :: MonadIRBuilder m => m ()+retVoid = emitTerm (Ret Nothing [])++call :: MonadIRBuilder m => Operand -> [(Operand, [ParameterAttribute])] -> m Operand+call fun args = do+  let instr = Call {+    AST.tailCallKind = Nothing+  , AST.callingConvention = CC.C+  , AST.returnAttributes = []+  , AST.function = Right fun+  , AST.arguments = args+  , 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)."++ret :: MonadIRBuilder m => Operand -> m ()+ret val = emitTerm (Ret (Just val) [])++switch :: MonadIRBuilder m => Operand -> Name -> [(C.Constant, Name)] -> m ()+switch val def dests = emitTerm $ Switch val def dests []++select :: MonadIRBuilder m => Operand -> Operand -> Operand -> m Operand+select cond t f = emitInstr (typeOf t) $ Select cond t f []++condBr :: MonadIRBuilder m => Operand -> Name -> Name -> m ()+condBr cond tdest fdest = emitTerm $ CondBr cond tdest fdest []++unreachable :: MonadIRBuilder m => m ()+unreachable = emitTerm $ Unreachable []

@@ -0,0 +1,16 @@+module LLVM.IRBuilder.Internal.SnocList where++import LLVM.Prelude++newtype SnocList a = SnocList { unSnocList :: [a] }+  deriving (Eq, Show)++instance Monoid (SnocList a) where+  mappend (SnocList xs) (SnocList ys) = SnocList $ ys ++ xs+  mempty = SnocList []++snoc :: SnocList a -> a -> SnocList a+snoc (SnocList xs) x = SnocList $ x : xs++getSnocList :: SnocList a -> [a]+getSnocList = reverse . unSnocList

@@ -0,0 +1,199 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-} -- For MonadState s (IRBuilderT m) instance++module LLVM.IRBuilder.Module where++import Prelude hiding (and, or)++import Control.Applicative+import Control.Monad.Cont+import Control.Monad.Except+import Control.Monad.Fail+import qualified Control.Monad.Fail as Fail+import Control.Monad.Identity+import Control.Monad.Writer.Lazy as Lazy+import Control.Monad.Writer.Strict as Strict+import Control.Monad.Reader+import Control.Monad.RWS.Lazy as Lazy+import Control.Monad.RWS.Strict as Strict+import qualified Control.Monad.State.Lazy as Lazy+import Control.Monad.State.Strict+import Control.Monad.List+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Identity++import Data.Bifunctor+import Data.ByteString.Short as BS+import Data.Char+import Data.Data+import Data.String++import GHC.Generics(Generic)++import LLVM.AST hiding (function)+import LLVM.AST.Global+import LLVM.AST.Linkage+import qualified LLVM.AST.Constant as C++import LLVM.IRBuilder.Internal.SnocList+import LLVM.IRBuilder.Monad++newtype ModuleBuilderT m a = ModuleBuilderT { unModuleBuilderT :: StateT ModuleBuilderState m a }+  deriving+    ( Functor, Alternative, Applicative, Monad, MonadCont, MonadError e+    , MonadFix, MonadIO, MonadPlus, MonadReader r, MonadTrans, MonadWriter w+    )++instance MonadFail m => MonadFail (ModuleBuilderT m) where+  fail str = ModuleBuilderT (StateT $ \_ -> Fail.fail str)++newtype ModuleBuilderState = ModuleBuilderState+  { builderDefs :: SnocList Definition+  }++emptyModuleBuilder :: ModuleBuilderState+emptyModuleBuilder = ModuleBuilderState+  { builderDefs = mempty+  }++type ModuleBuilder = ModuleBuilderT Identity++class Monad m => MonadModuleBuilder m where+  liftModuleState :: State ModuleBuilderState a -> m a++  default liftModuleState+    :: (MonadTrans t, MonadModuleBuilder m1, m ~ t m1)+    => State ModuleBuilderState a+    -> m a+  liftModuleState = lift . liftModuleState++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++-- | Evaluate 'ModuleBuilderT' to a result and a list of definitions+runModuleBuilderT :: Monad m => ModuleBuilderState -> ModuleBuilderT m a -> m (a, [Definition])+runModuleBuilderT s (ModuleBuilderT m)+  = second (getSnocList . builderDefs)+  <$> runStateT m s++-- | Evaluate 'ModuleBuilder' to a list of definitions+execModuleBuilder :: ModuleBuilderState -> ModuleBuilder a -> [Definition]+execModuleBuilder s m = snd $ runModuleBuilder s m++-- | Evaluate 'ModuleBuilderT' to a list of definitions+execModuleBuilderT :: Monad m => ModuleBuilderState -> ModuleBuilderT m a -> m [Definition]+execModuleBuilderT s m = snd <$> runModuleBuilderT s m++emitDefn :: MonadModuleBuilder m => Definition -> m ()+emitDefn def = liftModuleState $ modify $ \s -> s { builderDefs = builderDefs s `snoc` def }++-- | A parameter name suggestion+data ParameterName+  = NoParameterName+  | ParameterName ShortByteString+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | Using 'fromString` on non-ASCII strings will throw an error.+instance IsString ParameterName where+  fromString s+    | all isAscii s = ParameterName (fromString s)+    | otherwise =+      error ("Only ASCII strings are automatically converted to LLVM parameter names. "+      <> "Other strings need to be encoded to a `ShortByteString` using an arbitrary encoding.")++-- | Define and emit a (non-variadic) function definition+function+  :: MonadModuleBuilder m+  => Name  -- ^ Function name+  -> [(Type, ParameterName)]  -- ^ Parameter types and name suggestions+  -> Type  -- ^ Return type+  -> ([Operand] -> IRBuilderT m ())  -- ^ Function body builder+  -> m Operand+function label argtys retty body = do+  let tys = fst <$> argtys+  (paramNames, blocks) <- runIRBuilderT emptyIRBuilder $ do+    paramNames <- forM argtys $ \(_, paramName) -> case paramName of+      NoParameterName -> fresh+      ParameterName p -> fresh `named` p+    body $ zipWith LocalReference tys paramNames+    return paramNames+  let+    def = GlobalDefinition functionDefaults+      { name        = label+      , parameters  = (zipWith (\ty nm -> Parameter ty nm []) tys paramNames, False)+      , returnType  = retty+      , basicBlocks = blocks+      }+    funty = FunctionType retty (fst <$> argtys) False+  emitDefn def+  pure $ ConstantOperand $ C.GlobalReference funty label++-- | An external function definition+extern+  :: MonadModuleBuilder m+  => Name   -- ^ Definition name+  -> [Type] -- ^ Parametere types+  -> Type   -- ^ Type+  -> m Operand+extern nm argtys retty = do+  emitDefn $ GlobalDefinition functionDefaults+    { name        = nm+    , linkage     = External+    , parameters  = ([Parameter ty (mkName "") [] | ty <- argtys], False)+    , returnType  = retty+    }+  let funty = FunctionType retty argtys False+  pure $ ConstantOperand $ C.GlobalReference funty nm++-- | A named type definition+typedef+  :: MonadModuleBuilder m+  => Name+  -> Maybe Type+  -> m ()+typedef nm ty = do+  emitDefn $ TypeDefinition nm ty+  pure ()++-- | Convenience function for module construction+buildModule :: ShortByteString -> ModuleBuilder a -> Module+buildModule nm = mkModule . execModuleBuilder emptyModuleBuilder+  where+    mkModule ds = defaultModule { moduleName = nm, moduleDefinitions = ds }++-- | Convenience function for module construction (transformer version)+buildModuleT :: Monad m => ShortByteString -> ModuleBuilderT m a -> m Module+buildModuleT nm = fmap mkModule . execModuleBuilderT emptyModuleBuilder+  where+    mkModule ds = defaultModule { moduleName = nm, moduleDefinitions = ds }++-------------------------------------------------------------------------------+-- mtl instances+-------------------------------------------------------------------------------++instance MonadState s m => MonadState s (ModuleBuilderT m) where+  state = lift . state++instance MonadModuleBuilder m => MonadModuleBuilder (ContT r m)+instance MonadModuleBuilder m => MonadModuleBuilder (ExceptT e m)+instance MonadModuleBuilder m => MonadModuleBuilder (IdentityT m)+instance MonadModuleBuilder m => MonadModuleBuilder (ListT m)+instance MonadModuleBuilder m => MonadModuleBuilder (MaybeT m)+instance MonadModuleBuilder m => MonadModuleBuilder (ReaderT r m)+instance (MonadModuleBuilder m, Monoid w) => MonadModuleBuilder (Strict.RWST r w s m)+instance (MonadModuleBuilder m, Monoid w) => MonadModuleBuilder (Lazy.RWST r w s m)+instance MonadModuleBuilder m => MonadModuleBuilder (StateT s m)+instance MonadModuleBuilder m => MonadModuleBuilder (Lazy.StateT s m)+instance (Monoid w, MonadModuleBuilder m) => MonadModuleBuilder (Strict.WriterT w m)+instance (Monoid w, MonadModuleBuilder m) => MonadModuleBuilder (Lazy.WriterT w m)

@@ -0,0 +1,251 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-} -- For MonadState s (ModuleBuilderT m) instance++module LLVM.IRBuilder.Monad where++import LLVM.Prelude++import Control.Monad.Cont+import Control.Monad.Except+import Control.Monad.Fail+import qualified Control.Monad.Fail as Fail+import Control.Monad.Identity+import Control.Monad.Writer.Lazy as Lazy+import Control.Monad.Writer.Strict as Strict+import Control.Monad.Reader+import Control.Monad.RWS.Lazy as Lazy+import Control.Monad.RWS.Strict as Strict+import qualified Control.Monad.State.Lazy as Lazy+import Control.Monad.State.Strict+import Control.Monad.List+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Identity++import Data.Bifunctor+import Data.String+import Data.HashSet(HashSet)+import qualified Data.HashSet as HS++import LLVM.AST++import LLVM.IRBuilder.Internal.SnocList++-- | This provides a uniform API for creating instructions and inserting them+-- into a basic block: either at the end of a BasicBlock, or at a specific+-- location in a block.+newtype IRBuilderT m a = IRBuilderT { unIRBuilderT :: StateT IRBuilderState m a }+  deriving+    ( Functor, Alternative, Applicative, Monad, MonadCont, MonadError e+    , MonadFix, MonadIO, MonadPlus, MonadReader r, MonadTrans, MonadWriter w+    )++instance MonadFail m => MonadFail (IRBuilderT m) where+    fail str = IRBuilderT (StateT $ \ _ -> Fail.fail str)++type IRBuilder = IRBuilderT Identity++class Monad m => MonadIRBuilder m where+  liftIRState :: State IRBuilderState a -> m a++  default liftIRState+    :: (MonadTrans t, MonadIRBuilder m1, m ~ t m1)+    => State IRBuilderState a+    -> m a+  liftIRState = lift . liftIRState++instance Monad m => MonadIRBuilder (IRBuilderT m) where+  liftIRState (StateT s) = IRBuilderT $ StateT $ pure . runIdentity . s++-- | A partially constructed block as a sequence of instructions+data PartialBlock = PartialBlock+  { partialBlockName :: !Name+  , partialBlockInstrs :: SnocList (Named Instruction)+  , partialBlockTerm :: Maybe (Named Terminator)+  }++emptyPartialBlock :: Name -> PartialBlock+emptyPartialBlock nm = PartialBlock nm mempty Nothing++-- | Builder monad state+data IRBuilderState = IRBuilderState+  { builderSupply :: !Word+  , builderUsedNames :: !(HashSet ShortByteString)+  , builderNameSuggestion :: !(Maybe ShortByteString)+  , builderBlocks :: SnocList BasicBlock+  , builderBlock :: !(Maybe PartialBlock)+  }++emptyIRBuilder :: IRBuilderState+emptyIRBuilder = IRBuilderState+  { builderSupply = 0+  , builderUsedNames = mempty+  , builderNameSuggestion = Nothing+  , builderBlocks = mempty+  , builderBlock = Nothing+  }++-- | Evaluate IRBuilder to a result and a list of basic blocks+runIRBuilder :: IRBuilderState -> IRBuilder a -> (a, [BasicBlock])+runIRBuilder s m = runIdentity $ runIRBuilderT s m++-- | Evaluate IRBuilderT to a result and a list of basic blocks+runIRBuilderT :: Monad m => IRBuilderState -> IRBuilderT m a -> m (a, [BasicBlock])+runIRBuilderT s m+  = second (getSnocList . builderBlocks)+  <$> runStateT (unIRBuilderT $ m <* block) s++-- | Evaluate IRBuilder to a list of basic blocks+execIRBuilder :: IRBuilderState -> IRBuilder a -> [BasicBlock]+execIRBuilder s m = snd $ runIRBuilder s m++-- | Evaluate IRBuilderT to a list of basic blocks+execIRBuilderT :: Monad m => IRBuilderState -> IRBuilderT m a -> m [BasicBlock]+execIRBuilderT s m = snd <$> runIRBuilderT s m++-------------------------------------------------------------------------------+-- * Low-level functionality+-------------------------------------------------------------------------------++modifyBlock+  :: MonadIRBuilder m+  => (PartialBlock -> PartialBlock)+  -> m ()+modifyBlock f = do+  mbb <- liftIRState $ gets builderBlock+  case mbb of+    Nothing -> do+      nm <- freshUnName+      liftIRState $ modify $ \s -> s { builderBlock = Just $! f $ emptyPartialBlock nm }+    Just bb ->+      liftIRState $ modify $ \s -> s { builderBlock = Just $! f bb }++-- | Generate a fresh name. The resulting name is numbered or+-- based on the name suggested with 'named' if that's used.+fresh :: MonadIRBuilder m => m Name+fresh = do+  msuggestion <- liftIRState $ gets builderNameSuggestion+  maybe freshUnName freshName msuggestion++-- | Generate a fresh name from a name suggestion+freshName :: MonadIRBuilder m => ShortByteString -> m Name+freshName suggestion = do+  usedNames <- liftIRState $ gets builderUsedNames+  let+    candidates = suggestion : [suggestion <> fromString (show n) | n <- [(1 :: Int)..]]+    (unusedName:_) = filter (not . (`HS.member` usedNames)) candidates+  liftIRState $ modify $ \s -> s { builderUsedNames = HS.insert unusedName $ builderUsedNames s }+  return $ Name unusedName++-- | Generate a fresh numbered name+freshUnName :: MonadIRBuilder m => m Name+freshUnName = liftIRState $ do+  n <- gets builderSupply+  modify $ \s -> s { builderSupply = 1 + n }+  pure $ UnName n++-- | Emit instruction+emitInstr+  :: MonadIRBuilder m+  => Type -- ^ Return type+  -> Instruction+  -> m Operand+emitInstr retty instr = do+  nm <- fresh+  modifyBlock $ \bb -> bb+    { partialBlockInstrs = partialBlockInstrs bb `snoc` (nm := instr)+    }+  pure (LocalReference retty nm)++-- | Emit instruction that returns void+emitInstrVoid+  :: MonadIRBuilder m+  => Instruction+  -> m ()+emitInstrVoid instr = do+  modifyBlock $ \bb -> bb+    { partialBlockInstrs = partialBlockInstrs bb `snoc` (Do instr)+    }+  pure ()++-- | Emit terminator+emitTerm+  :: MonadIRBuilder m+  => Terminator+  -> m ()+emitTerm term = modifyBlock $ \bb -> bb+  { partialBlockTerm = Just (Do term)+  }++-- | Starts a new block labelled using the given name and ends the previous+-- one. The name is assumed to be fresh.+emitBlockStart+  :: MonadIRBuilder m+  => Name+  -> m ()+emitBlockStart nm = do+  mbb <- liftIRState $ gets builderBlock+  case mbb of+    Nothing -> return ()+    Just bb -> do+      let+        instrs = getSnocList $ partialBlockInstrs bb+        newBb = case partialBlockTerm bb of+          Nothing   -> BasicBlock (partialBlockName bb) instrs (Do (Ret Nothing []))+          Just term -> BasicBlock (partialBlockName bb) instrs term+      liftIRState $ modify $ \s -> s+        { builderBlocks = builderBlocks s `snoc` newBb+        }+  liftIRState $ modify $ \s -> s { builderBlock = Just $ emptyPartialBlock nm }++-------------------------------------------------------------------------------+-- * High-level functionality+-------------------------------------------------------------------------------++-- | Starts a new block and ends the previous one+block+  :: MonadIRBuilder m+  => m Name+block = do+  nm <- fresh+  emitBlockStart nm+  return nm++-- | @ir `named` name@ executes the 'IRBuilder' @ir@ using @name@ as the base+-- name whenever a fresh local name is generated. Collisions are avoided by+-- appending numbers (first @"name"@, then @"name1"@, @"name2"@, and so on).+named+  :: MonadIRBuilder m+  => m r+  -> ShortByteString+  -> m r+named ir name = do+  before <- liftIRState $ gets builderNameSuggestion+  liftIRState $ modify $ \s -> s { builderNameSuggestion = Just name }+  result <- ir+  liftIRState $ modify $ \s -> s { builderNameSuggestion = before }+  return result++-------------------------------------------------------------------------------+-- mtl instances+-------------------------------------------------------------------------------++instance MonadState s m => MonadState s (IRBuilderT m) where+  state = lift . state++instance MonadIRBuilder m => MonadIRBuilder (ContT r m)+instance MonadIRBuilder m => MonadIRBuilder (ExceptT e m)+instance MonadIRBuilder m => MonadIRBuilder (IdentityT m)+instance MonadIRBuilder m => MonadIRBuilder (ListT m)+instance MonadIRBuilder m => MonadIRBuilder (MaybeT m)+instance MonadIRBuilder m => MonadIRBuilder (ReaderT r m)+instance (MonadIRBuilder m, Monoid w) => MonadIRBuilder (Strict.RWST r w s m)+instance (MonadIRBuilder m, Monoid w) => MonadIRBuilder (Lazy.RWST r w s m)+instance MonadIRBuilder m => MonadIRBuilder (StateT s m)+instance MonadIRBuilder m => MonadIRBuilder (Lazy.StateT s m)+instance (Monoid w, MonadIRBuilder m) => MonadIRBuilder (Strict.WriterT w m)+instance (Monoid w, MonadIRBuilder m) => MonadIRBuilder (Lazy.WriterT w m)

@@ -0,0 +1,239 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecursiveDo #-}+module Main+  ( main+  ) where++import           Data.Monoid+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.IO as T+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.Type as AST+import           Test.Hspec hiding (example)++import           LLVM.IRBuilder++main :: IO ()+main =+  hspec $ do+    describe "module builder" $ do+      it "builds the simple module" $+        simple `shouldBe`+        defaultModule {+          moduleName = "exampleModule",+          moduleDefinitions =+            [ GlobalDefinition functionDefaults {+                name = "add",+                parameters =+                  ( [ Parameter AST.i32 "a" []+                    , Parameter AST.i32 "b" []+                    ]+                  , False+                  ),+                returnType = AST.i32,+                basicBlocks =+                  [ BasicBlock+                      "entry"+                      [ UnName 0 := Add {+                          operand0 = LocalReference AST.i32 "a",+                          operand1 = LocalReference AST.i32 "b",+                          nsw = False,+                          nuw = False,+                          metadata = []+                        }+                      ]+                      (Do (Ret (Just (LocalReference AST.i32 (UnName 0))) []))+                  ]+              }+            ]+        }+      it "builds the example" $ do+        let f10 = ConstantOperand (C.Float (F.Double 10))+            fadd a b = FAdd { operand0 = a, operand1 = b, fastMathFlags = NoFastMathFlags, metadata = [] }+            add a b = Add { operand0 = a, operand1 = b, nsw = False, nuw = False, metadata = [] }+        example `shouldBe`+          defaultModule {+            moduleName = "exampleModule",+            moduleDefinitions =+              [ GlobalDefinition functionDefaults {+                  name = "foo",+                  returnType = AST.double,+                  basicBlocks =+                    [ BasicBlock (UnName 0) [ "xxx" := fadd f10 f10]+                        (Do (Ret Nothing []))+                    , BasicBlock+                        "blk"+                        [ UnName 1 := fadd f10 f10+                        , UnName 2 := fadd (LocalReference AST.double (UnName 1)) (LocalReference AST.double (UnName 1))+                        , UnName 3 := add (ConstantOperand (C.Int 32 10)) (ConstantOperand (C.Int 32 10))+                        ]+                        (Do (Br "blk1" []))+                    , BasicBlock+                        "blk1"+                        [ "c" := fadd f10 f10+                        , UnName 4 := fadd (LocalReference AST.double "c") (LocalReference AST.double "c")+                        ]+                        (Do (Br "blk2" []))+                    , BasicBlock+                        "blk2"+                        [ "phi" :=+                            Phi+                              AST.double+                              [ ( f10, "blk" )+                              , ( f10, "blk1" )+                              , ( f10, "blk2" )+                              ]+                              []+                        , UnName 5 := fadd f10 f10+                        , UnName 6 := fadd (LocalReference AST.double (UnName 5)) (LocalReference AST.double (UnName 5))+                        ]+                        (Do (Ret Nothing []))+                    ]+                }+              , GlobalDefinition functionDefaults {+                  name = "bar",+                  returnType = AST.double,+                  basicBlocks =+                    [ BasicBlock+                       (UnName 0)+                       [ UnName 1 := fadd f10 f10+                       , UnName 2 := fadd (LocalReference AST.double (UnName 1)) (LocalReference AST.double (UnName 1))+                       ]+                       (Do (Ret Nothing []))+                    ]+                }+              , GlobalDefinition functionDefaults {+                  name = "baz",+                  parameters =+                    ( [ Parameter AST.i32 (UnName 0) []+                      , Parameter AST.double "arg" []+                      , Parameter AST.i32 (UnName 1) []+                      , Parameter AST.double "arg1" []]+                    , False),+                  returnType = AST.double,+                  basicBlocks =+                    [ BasicBlock+                        (UnName 2)+                        []+                        (Do+                           (Switch+                             (LocalReference AST.i32 (UnName 1))+                             (UnName 3)+                             [ ( C.Int 32 0, UnName 4), ( C.Int 32 1, UnName 7) ] []))+                    , BasicBlock+                        (UnName 3)+                        []+                        (Do (Br (UnName 4) []))+                    , BasicBlock+                        (UnName 4)+                        [ "arg2" := fadd (LocalReference AST.double "arg") f10+                        , UnName 5 := fadd (LocalReference AST.double "arg2") (LocalReference AST.double "arg2")+                        , UnName 6 := Select {+                            condition' = ConstantOperand (C.Int 1 0),+                            trueValue = LocalReference AST.double "arg2",+                            falseValue = LocalReference AST.double (UnName 5),+                            metadata = []+                          }+                        ]+                        (Do (Ret Nothing []))+                    , BasicBlock+                        (UnName 7)+                        [ UnName 8 := GetElementPtr {+                            inBounds = False,+                            address = ConstantOperand (C.Null (AST.ptr (AST.ptr (AST.ptr AST.i32)))),+                            indices =+                              [ ConstantOperand (C.Int 32 10)+                              , ConstantOperand (C.Int 32 20)+                              , ConstantOperand (C.Int 32 30)+                              ],+                            metadata = []+                          }+                        , UnName 9 := GetElementPtr {+                            inBounds = False,+                            address = LocalReference (AST.ptr AST.i32) (UnName 8),+                            indices = [ ConstantOperand (C.Int 32 40) ],+                            metadata = []+                          }+                        ]+                        (Do (Ret Nothing []))+                    ]+                }+              ]+          }++simple :: Module+simple = buildModule "exampleModule" $ mdo++  function "add" [(AST.i32, "a"), (AST.i32, "b")] AST.i32 $ \[a, b] -> mdo++    entry <- block `named` "entry"; do+      c <- add a b+      ret c++example :: Module+example = mkModule $ execModuleBuilder emptyModuleBuilder $ mdo++  foo <- function "foo" [] AST.double $ \_ -> mdo+    xxx <- fadd c1 c1 `named` "xxx"++    blk1 <- block `named` "blk"; do+      a <- fadd c1 c1+      b <- fadd a a+      c <- add c2 c2+      br blk2++    blk2 <- block `named` "blk"; do+      a <- fadd c1 c1 `named` "c"+      b <- fadd a a+      br blk3++    blk3 <- block `named` "blk"; do+      l <- phi [(c1, blk1), (c1, blk2), (c1, blk3)] `named` "phi"+      a <- fadd c1 c1+      b <- fadd a a+      retVoid++    pure ()+++  function "bar" [] AST.double $ \_ -> mdo++    blk3 <- block; do+      a <- fadd c1 c1+      b <- fadd a a+      retVoid++    pure ()++  function "baz" [(AST.i32, NoParameterName), (AST.double, "arg"), (AST.i32, NoParameterName), (AST.double, "arg")] AST.double $ \[rrr, arg, arg2, arg3] -> mdo++    switch arg2 blk1 [(C.Int 32 0, blk2), (C.Int 32 1, blk3)]++    blk1 <- block; do+      br blk2++    blk2 <- block; do+      a <- fadd arg c1 `named` "arg"+      b <- fadd a a+      select (cons $ C.Int 1 0) a b+      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]+      retVoid++    pure ()+  where+    mkModule ds = defaultModule { moduleName = "exampleModule", moduleDefinitions = ds }+    cons = ConstantOperand++c1 :: Operand+c1 = ConstantOperand $ C.Float (F.Double 10)++c2 :: Operand+c2 = ConstantOperand $ C.Int 32 10