llvm-codegen (empty) → 0.1.0.0
raw patch · 20 files changed
+3735/−0 lines, 20 filesdep +basedep +bytestringdep +containersbuild-type:Customsetup-changed
Dependencies added: base, bytestring, containers, dlist, ghc-prim, hspec, hspec-hedgehog, llvm-codegen, mmorph, mtl, neat-interpolation, text, text-builder-linear
Files
- LICENSE +30/−0
- README.md +24/−0
- Setup.hs +220/−0
- lib/LLVM/C/API.hs +134/−0
- lib/LLVM/C/Bindings.hs +109/−0
- lib/LLVM/Codegen.hs +25/−0
- lib/LLVM/Codegen/Flag.hs +12/−0
- lib/LLVM/Codegen/IR.hs +283/−0
- lib/LLVM/Codegen/IRBuilder.hs +479/−0
- lib/LLVM/Codegen/IRBuilder/Monad.hs +306/−0
- lib/LLVM/Codegen/ModuleBuilder.hs +332/−0
- lib/LLVM/Codegen/Name.hs +31/−0
- lib/LLVM/Codegen/Operand.hs +70/−0
- lib/LLVM/Codegen/Type.hs +63/−0
- lib/LLVM/Pretty.hs +112/−0
- llvm-codegen.cabal +130/−0
- tests/Test/LLVM/C/APISpec.hs +118/−0
- tests/Test/LLVM/Codegen/IRBuilderSpec.hs +881/−0
- tests/Test/LLVM/Codegen/IRCombinatorsSpec.hs +374/−0
- tests/test.hs +2/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Luc Tielen (c) 2022++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Luc Tielen nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,24 @@+# llvm-codegen++[](https://github.com/luc-tielen/llvm-codegen/actions/workflows/ci.yml)++A Haskell library for generating LLVM code. Inspired by the `llvm-hs`,+`llvm-hs-pure`, `llvm-hs-combinators` and the `llvm-hs-pretty` libraries.++**NOTE:** WIP, but if you only need the provided instructions it's usable (and+tested). Used inside the [eclair compiler](https://github.com/luc-tielen/eclair-lang.git).++Note that it requires LLVM to be installed on your system and available on your+`$PATH`!++## Why another LLVM library?++- Support for the latest LLVM (!)+- Support for latest GHCs++## TODO++- [ ] Add support for remaining instructions as needed+- [ ] SIMD support, combinators+- [ ] Support API with more compile time checks?+- [ ] Documentation
+ Setup.hs view
@@ -0,0 +1,220 @@+-- NOTE: Copied from the llvm-hs project. Only modification is the LLVM version.++{-# LANGUAGE CPP, FlexibleInstances #-}+import Control.Exception (SomeException, try)+import Control.Monad+import Data.Char+import Data.List+import Data.Maybe+import Data.Monoid+import Distribution.PackageDescription hiding (buildInfo, includeDirs)+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.PreProcess+import Distribution.Simple.Program+import Distribution.Simple.Setup hiding (Flag)+import Distribution.System+import System.Environment++#ifdef MIN_VERSION_Cabal+#if MIN_VERSION_Cabal(2,0,0)+#define MIN_VERSION_Cabal_2_0_0+#endif+#endif++-- define these selectively in C files (we are _not_ using HsFFI.h),+-- rather than universally in the ccOptions, because HsFFI.h currently defines them+-- without checking they're already defined and so causes warnings.+uncheckedHsFFIDefines :: [String]+uncheckedHsFFIDefines = ["__STDC_LIMIT_MACROS"]++#ifndef MIN_VERSION_Cabal_2_0_0+mkVersion :: [Int] -> Version+mkVersion ver = Version ver []+versionNumbers :: Version -> [Int]+versionNumbers = versionBranch+mkFlagName :: String -> FlagName+mkFlagName = FlagName+#endif++#if !(MIN_VERSION_Cabal(2,1,0))+lookupFlagAssignment :: FlagName -> FlagAssignment -> Maybe Bool+lookupFlagAssignment = lookup+#endif++supportedLLVMVersions :: [Version]+supportedLLVMVersions =+ [ mkVersion [17,99,99] -- TODO find a proper fix for this so all versions of 17 are allowed+ , mkVersion [16,0,0]+ , mkVersion [15,0,0]+ ]++-- Ordered by decreasing specificty so we will prefer llvm-config-17.0+-- over llvm-config-17 over llvm-config. Also looks for newer LLVM versions first+llvmConfigNames :: [String]+llvmConfigNames = reverse versionedConfigs ++ ["llvm-config"]+ where+ versionSuffixes :: [[Int]]+ versionSuffixes =+ concatMap (\v -> tail (inits (versionNumbers v))) supportedLLVMVersions+ versionedConfigs =+ map (\vs -> "llvm-config-" <> intercalate "." (map show vs)) versionSuffixes++findJustBy :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)+findJustBy f (x:xs) = do+ x' <- f x+ case x' of+ Nothing -> findJustBy f xs+ j -> return j+findJustBy _ [] = return Nothing++llvmProgram :: Program+llvmProgram = (simpleProgram "llvm-config") {+ programFindLocation = \v p -> findJustBy (\n -> programFindLocation (simpleProgram n) v p) llvmConfigNames,+ programFindVersion = \verbosity path ->+ let+ stripVcsSuffix = takeWhile (\c -> isDigit c || c == '.')+ trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse+ in findProgramVersion "--version" (stripVcsSuffix . trim) verbosity path+ }++betweenVersions :: Version -> Version -> VersionRange+betweenVersions minVersion maxVersion =+ intersectVersionRanges+ (orLaterVersion minVersion)+ (orEarlierVersion maxVersion)++getLLVMConfig :: ConfigFlags -> IO ([String] -> IO String)+getLLVMConfig confFlags = do+ let verbosity = fromFlag $ configVerbosity confFlags+ minVersion = minimum supportedLLVMVersions+ maxVersion = maximum supportedLLVMVersions+ -- llvm-config >= min version && <= max version+ versionRange = betweenVersions minVersion maxVersion+ (program, _, _) <- requireProgramVersion verbosity llvmProgram+ versionRange+ (configPrograms confFlags)+ return $ getProgramOutput verbosity program++addToLdLibraryPath :: String -> IO ()+addToLdLibraryPath path = do+ let (ldLibraryPathVar, ldLibraryPathSep) =+ case buildOS of+ OSX -> ("DYLD_LIBRARY_PATH",":")+ _ -> ("LD_LIBRARY_PATH",":")+ v <- try $ getEnv ldLibraryPathVar :: IO (Either SomeException String)+ setEnv ldLibraryPathVar (path ++ either (const "") (ldLibraryPathSep ++) v)++addLLVMToLdLibraryPath :: ConfigFlags -> IO ()+addLLVMToLdLibraryPath confFlags = do+ llvmConfig <- getLLVMConfig confFlags+ [libDir] <- liftM lines $ llvmConfig ["--libdir"]+ addToLdLibraryPath libDir++-- | These flags are not relevant for us and dropping them allows+-- linking against LLVM build with Clang using GCC+ignoredCxxFlags :: [String]+ignoredCxxFlags = ["-fcolor-diagnostics"] ++ map ("-D" ++) uncheckedHsFFIDefines++ignoredCFlags :: [String]+ignoredCFlags = ["-fcolor-diagnostics"]++-- | Header directories are added separately to configExtraIncludeDirs+isIncludeFlag :: String -> Bool+isIncludeFlag flag = "-I" `isPrefixOf` flag++isWarningFlag :: String -> Bool+isWarningFlag flag = "-W" `isPrefixOf` flag++isIgnoredCFlag :: String -> Bool+isIgnoredCFlag flag = flag `elem` ignoredCFlags || isIncludeFlag flag || isWarningFlag flag++isIgnoredCxxFlag :: String -> Bool+isIgnoredCxxFlag flag = flag `elem` ignoredCxxFlags || isIncludeFlag flag || isWarningFlag flag++main :: IO ()+main = do+ let origUserHooks = simpleUserHooks++ defaultMainWithHooks origUserHooks {+ hookedPrograms = [ llvmProgram ],++ confHook = \(genericPackageDescription, hookedBuildInfo) confFlags -> do+ llvmConfig <- getLLVMConfig confFlags+ llvmCxxFlags <- do+ rawLlvmCxxFlags <- llvmConfig ["--cxxflags"]+ return . filter (not . isIgnoredCxxFlag) $ words rawLlvmCxxFlags+ let stdLib = maybe "stdc++"+ (drop (length stdlibPrefix))+ (find (isPrefixOf stdlibPrefix) llvmCxxFlags)+ where stdlibPrefix = "-stdlib=lib"+ includeDirs <- liftM lines $ llvmConfig ["--includedir"]+ libDirs <- liftM lines $ llvmConfig ["--libdir"]+ [llvmVersion] <- liftM lines $ llvmConfig ["--version"]+ let getLibs = liftM (map (fromJust . stripPrefix "-l") . words) . llvmConfig+ flags = configConfigurationsFlags confFlags+ linkFlag = case lookupFlagAssignment (mkFlagName "shared-llvm") flags of+ Nothing -> "--link-shared"+ Just shared -> if shared then "--link-shared" else "--link-static"+ libs <- getLibs ["--libs", linkFlag]+ systemLibs <- getLibs ["--system-libs", linkFlag]++ let genericPackageDescription' = genericPackageDescription {+ condLibrary = do+ libraryCondTree <- condLibrary genericPackageDescription+ return libraryCondTree {+ condTreeData = condTreeData libraryCondTree <> mempty {+ libBuildInfo =+ mempty {+ ccOptions = llvmCxxFlags,+ extraLibs = libs ++ stdLib : systemLibs+ }+ }+ }+ }+ configFlags' = confFlags {+ configExtraLibDirs = libDirs ++ configExtraLibDirs confFlags,+ configExtraIncludeDirs = includeDirs ++ configExtraIncludeDirs confFlags+ }+ addLLVMToLdLibraryPath configFlags'+ confHook simpleUserHooks (genericPackageDescription', hookedBuildInfo) configFlags',++ hookedPreProcessors =+ let origHookedPreprocessors = hookedPreProcessors origUserHooks+#ifdef MIN_VERSION_Cabal_2_0_0+ newHsc buildInfo localBuildInfo componentLocalBuildInfo =+#else+ newHsc buildInfo localBuildInfo =+#endif+ PreProcessor+ { platformIndependent = platformIndependent (origHsc buildInfo)+ , runPreProcessor = \inFiles outFiles verbosity -> do+ llvmConfig <- getLLVMConfig (configFlags localBuildInfo)+ llvmCFlags <- do+ rawLlvmCFlags <- llvmConfig ["--cflags"]+ return . filter (not . isIgnoredCFlag) $ words rawLlvmCFlags+ let buildInfo' = buildInfo { ccOptions = "-Wno-variadic-macros" : llvmCFlags }+ runPreProcessor (origHsc buildInfo') inFiles outFiles verbosity+#if MIN_VERSION_Cabal(3,8,1)+ , ppOrdering = \_verbosity _paths modules -> pure modules+#endif+ }+ where origHsc buildInfo' =+ fromMaybe+ ppHsc2hs+ (lookup "hsc" origHookedPreprocessors)+ buildInfo'+ localBuildInfo+#ifdef MIN_VERSION_Cabal_2_0_0+ componentLocalBuildInfo+#endif+ in [("hsc", newHsc)] ++ origHookedPreprocessors,++ buildHook = \packageDesc localBuildInfo userHooks buildFlags ->+ do addLLVMToLdLibraryPath (configFlags localBuildInfo)+ buildHook origUserHooks packageDesc localBuildInfo userHooks buildFlags,++ testHook = \args packageDesc localBuildInfo userHooks testFlags ->+ do addLLVMToLdLibraryPath (configFlags localBuildInfo)+ testHook origUserHooks args packageDesc localBuildInfo userHooks testFlags+ }
+ lib/LLVM/C/API.hs view
@@ -0,0 +1,134 @@+module LLVM.C.API+ ( Context+ , Module+ , TargetData+ , Type+ , mkContext+ , mkModule+ , mkTargetData+ , setTargetData+ , getTargetData+ , sizeOfType++ , getTypeByName+ , mkVoidType+ , mkIntType+ , mkPointerType+ , mkArrayType+ , mkFunctionType+ , mkAnonStructType+ , mkOpaqueStructType+ , setNamedStructBody+ ) where++import Data.Word+import Foreign.C+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.Marshal.Array+import Control.Exception+import Data.Text (Text)+import qualified Data.Text as T+import LLVM.C.Bindings+import LLVM.Codegen.Name+import LLVM.Codegen.Flag+import qualified LLVM.Codegen.Type as LLVMType+++mkVoidType :: ForeignPtr Context -> IO (Ptr Type)+mkVoidType ctx = withForeignPtr ctx llvmVoidTypeInContext++mkIntType :: ForeignPtr Context -> Word32 -> IO (Ptr Type)+mkIntType ctx bits = withForeignPtr ctx $ \c ->+ case bits of+ 1 -> llvmI1TypeInContext c+ 8 -> llvmI8TypeInContext c+ 16 -> llvmI16TypeInContext c+ 32 -> llvmI32TypeInContext c+ 64 -> llvmI64TypeInContext c+ _ -> llvmIntTypeInContext c (CUInt bits)++mkPointerType :: Ptr Type -> IO (Ptr Type)+mkPointerType pointeeTy =+ llvmPointerTypeInContext pointeeTy 0++mkAnonStructType :: ForeignPtr Context -> [Ptr Type] -> Flag LLVMType.Packed -> IO (Ptr Type)+mkAnonStructType ctx tys packed =+ withForeignPtr ctx $ \c ->+ withArray tys $ \tyArray -> do+ let count = CUInt $ fromIntegral $ length tys+ packed' = CBool (if packed == On then 1 else 0)+ llvmStructTypeInContext c tyArray count packed'++-- NOTE: can be used to forward declare a struct type+mkOpaqueStructType :: ForeignPtr Context -> Name -> IO (Ptr Type)+mkOpaqueStructType ctx name =+ withForeignPtr ctx $ \c ->+ withNameAsCString name $ \nm ->+ llvmNamedStructTypeInContext c nm++withNameAsCString :: Name -> (CString -> IO a) -> IO a+withNameAsCString name =+ withCString (T.unpack $ unName name)++-- NOTE: call this on a Type returned by 'mkOpaqueStructType' to define the struct body of that type.+setNamedStructBody :: Ptr Type -> [Ptr Type] -> Flag LLVMType.Packed -> IO ()+setNamedStructBody structTy tys packed =+ withArray tys $ \tyArray -> do+ let count = CUInt $ fromIntegral $ length tys+ packed' = CBool (if packed == On then 1 else 0)+ llvmNamedStructSetBody structTy tyArray count packed'++mkArrayType :: Ptr Type -> Word32 -> IO (Ptr Type)+mkArrayType elemTy count =+ llvmArrayTypeInContext elemTy (CUInt count)++mkFunctionType :: Ptr Type -> [Ptr Type] -> IO (Ptr Type)+mkFunctionType retTy argTys =+ withArray argTys $ \argTyArray -> do+ let argCount = CUInt $ fromIntegral $ length argTys+ isVarArg = CBool 0+ llvmFunctionTypeInContext retTy argTyArray argCount isVarArg++getTypeByName :: ForeignPtr Context -> Name -> IO (Ptr Type)+getTypeByName ctx name =+ withForeignPtr ctx $ \c ->+ withCString (T.unpack $ unName name) $ \str ->+ llvmGetTypeByNameInContext c str++mkContext :: IO (ForeignPtr Context)+mkContext = mask_ $ do+ ctx <- llvmContextCreate+ newForeignPtr llvmContextDispose ctx++mkModule :: ForeignPtr Context -> Text -> IO (ForeignPtr Module)+mkModule ctx name =+ withCString (T.unpack name) $ \name' -> do+ withForeignPtr ctx $ \c -> mask_ $ do+ llvmModule <- llvmCreateModuleWithName name' c+ -- TODO next line causes segfault? is this because some other field needs to get set first? or auto-cleaned up in context?+ -- newForeignPtr llvmDisposeModule llvmModule+ -- TODO: no longer need foreignptr wrapper then?+ newForeignPtr_ llvmModule++-- NOTE: no checks are made against the datalayout+mkTargetData :: String -> IO (ForeignPtr TargetData)+mkTargetData dl = mask_ $ do+ withCString dl $ \dlStr -> do+ td <- llvmCreateTargetData dlStr+ newForeignPtr llvmDisposeTargetData td++setTargetData :: ForeignPtr Module -> ForeignPtr TargetData -> IO ()+setTargetData llvmModule targetData = do+ withForeignPtr llvmModule $ \m ->+ withForeignPtr targetData $ \td ->+ llvmSetTargetData m td++getTargetData :: ForeignPtr Module -> IO (Ptr TargetData)+getTargetData llvmModule =+ withForeignPtr llvmModule llvmGetTargetData++sizeOfType :: Ptr TargetData -> Ptr Type -> IO Word64+sizeOfType td ty = do+ CSize byteSize <- llvmSizeOfType td ty+ pure byteSize
+ lib/LLVM/C/Bindings.hs view
@@ -0,0 +1,109 @@+module LLVM.C.Bindings+ ( Context+ , Module+ , TargetData+ , Type+ , llvmContextCreate+ , llvmContextDispose+ , llvmCreateModuleWithName+ , llvmDisposeModule+ , llvmCreateTargetData+ , llvmDisposeTargetData+ , llvmSetTargetData+ , llvmGetTargetData+ , llvmSizeOfType+ , llvmVoidTypeInContext+ , llvmI1TypeInContext+ , llvmI8TypeInContext+ , llvmI16TypeInContext+ , llvmI32TypeInContext+ , llvmI64TypeInContext+ , llvmIntTypeInContext+ , llvmPointerTypeInContext+ , llvmStructTypeInContext+ , llvmNamedStructTypeInContext+ , llvmNamedStructSetBody+ , llvmArrayTypeInContext+ , llvmFunctionTypeInContext+ , llvmGetTypeByNameInContext+ ) where++import Foreign.C+import Foreign.Ptr+++-- TODO: use ReaderT (ForeignPtr Context) IO a++data Context+data Module+data TargetData+data Type++foreign import ccall unsafe "LLVMContextCreate" llvmContextCreate+ :: IO (Ptr Context)++foreign import ccall unsafe "&LLVMContextDispose" llvmContextDispose+ :: FunPtr (Ptr Context -> IO ())++foreign import ccall unsafe "LLVMModuleCreateWithNameInContext" llvmCreateModuleWithName+ :: CString -> Ptr Context -> IO (Ptr Module)++foreign import ccall unsafe "&LLVMDisposeModule" llvmDisposeModule+ :: FunPtr (Ptr Module -> IO ())++foreign import ccall unsafe "LLVMCreateTargetData" llvmCreateTargetData+ :: CString -> IO (Ptr TargetData)++foreign import ccall unsafe "&LLVMDisposeTargetData" llvmDisposeTargetData+ :: FunPtr (Ptr TargetData -> IO ())++foreign import ccall unsafe "LLVMSetModuleDataLayout" llvmSetTargetData+ :: Ptr Module -> Ptr TargetData -> IO ()++foreign import ccall unsafe "LLVMGetModuleDataLayout" llvmGetTargetData+ :: Ptr Module -> IO (Ptr TargetData)++foreign import ccall unsafe "LLVMABISizeOfType" llvmSizeOfType+ :: Ptr TargetData -> Ptr Type -> IO CSize++foreign import ccall unsafe "LLVMVoidTypeInContext" llvmVoidTypeInContext+ :: Ptr Context -> IO (Ptr Type)++foreign import ccall unsafe "LLVMInt1TypeInContext" llvmI1TypeInContext+ :: Ptr Context -> IO (Ptr Type)++foreign import ccall unsafe "LLVMInt8TypeInContext" llvmI8TypeInContext+ :: Ptr Context -> IO (Ptr Type)++foreign import ccall unsafe "LLVMInt16TypeInContext" llvmI16TypeInContext+ :: Ptr Context -> IO (Ptr Type)++foreign import ccall unsafe "LLVMInt32TypeInContext" llvmI32TypeInContext+ :: Ptr Context -> IO (Ptr Type)++foreign import ccall unsafe "LLVMInt64TypeInContext" llvmI64TypeInContext+ :: Ptr Context -> IO (Ptr Type)++foreign import ccall unsafe "LLVMIntTypeInContext" llvmIntTypeInContext+ :: Ptr Context -> CUInt -> IO (Ptr Type)++foreign import ccall unsafe "LLVMPointerType" llvmPointerTypeInContext+ :: Ptr Type -> CUInt -> IO (Ptr Type)++foreign import ccall unsafe "LLVMStructTypeInContext" llvmStructTypeInContext+ :: Ptr Context -> Ptr (Ptr Type) -> CUInt -> CBool -> IO (Ptr Type)++foreign import ccall unsafe "LLVMStructCreateNamed" llvmNamedStructTypeInContext+ :: Ptr Context -> CString -> IO (Ptr Type)++foreign import ccall unsafe "LLVMStructSetBody" llvmNamedStructSetBody+ :: Ptr Type -> Ptr (Ptr Type) -> CUInt -> CBool -> IO ()++foreign import ccall unsafe "LLVMArrayType" llvmArrayTypeInContext+ :: Ptr Type -> CUInt -> IO (Ptr Type)++foreign import ccall unsafe "LLVMFunctionType" llvmFunctionTypeInContext+ :: Ptr Type -> Ptr (Ptr Type) -> CUInt -> CBool -> IO (Ptr Type)++foreign import ccall unsafe "LLVMGetTypeByName2" llvmGetTypeByNameInContext+ :: Ptr Context -> CString -> IO (Ptr Type)
+ lib/LLVM/Codegen.hs view
@@ -0,0 +1,25 @@+module LLVM.Codegen+ ( module LLVM.Codegen.IRBuilder+ , module LLVM.Codegen.ModuleBuilder+ , module LLVM.Codegen.Type+ , module LLVM.Codegen.Operand+ , module LLVM.Codegen.Name+ , module LLVM.Codegen.IR+ , module LLVM.Codegen.Flag+ , ppllvm+ ) where++import LLVM.Codegen.IRBuilder+import LLVM.Codegen.ModuleBuilder+import LLVM.Codegen.Type+import LLVM.Codegen.Operand+import LLVM.Codegen.Name+import LLVM.Codegen.IR+import LLVM.Codegen.Flag+import LLVM.Pretty+import Data.Text+++ppllvm :: Module -> Text+ppllvm = renderDoc renderModule+{-# INLINABLE ppllvm #-}
+ lib/LLVM/Codegen/Flag.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE RoleAnnotations #-}++module LLVM.Codegen.Flag+ ( Flag(..)+ ) where++data Flag a+ = On+ | Off+ deriving (Eq, Ord, Show)++type role Flag nominal
+ lib/LLVM/Codegen/IR.hs view
@@ -0,0 +1,283 @@+module LLVM.Codegen.IR+ ( IR(..)+ , Terminator(..)+ , ComparisonType(..)+ , CallingConvention(..)+ , TailCallAttribute(..)+ , SynchronizationScope(..)+ , MemoryOrdering(..)+ , Alignment+ , Flag(..)+ , NUW+ , NSW+ , Exact+ , Inbounds+ , Volatile+ , renderIR+ ) where++import Prelude hiding (EQ)+import LLVM.Codegen.Name+import LLVM.Codegen.Operand+import LLVM.Codegen.Type+import LLVM.Codegen.Flag+import LLVM.Pretty+import Data.Word+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE+++data NUW+data NSW+data Exact+data Inbounds+data Volatile++type Alignment = Word32++data SynchronizationScope+ = SingleThread+ | System+ deriving Show++data MemoryOrdering+ = Unordered+ | Monotonic+ | Acquire+ | Release+ | AcquireRelease+ | SequentiallyConsistent+ deriving Show++type Atomicity = (SynchronizationScope, MemoryOrdering)++data ComparisonType+ = EQ+ | NE+ | UGT+ | UGE+ | ULT+ | ULE+ | SGT+ | SGE+ | SLT+ | SLE+ deriving (Eq, Show)++data TailCallAttribute+ = Tail+ | MustTail+ | NoTail+ deriving Show++data CallingConvention+ = C+ | Fast+ -- TODO add others as needed+ deriving Show++data IR+ = Add !(Flag NUW) !(Flag NSW) !Operand !Operand+ | Mul !(Flag NUW) !(Flag NSW) !Operand !Operand+ | Sub !(Flag NUW) !(Flag NSW) !Operand !Operand+ | Udiv !(Flag Exact) !Operand !Operand+ | And !Operand !Operand+ | Or !Operand !Operand+ | Trunc !Operand !Type+ | Zext !Operand !Type+ | Bitcast !Operand !Type+ | ICmp !ComparisonType !Operand !Operand+ | PtrToInt !Operand !Type+ | Alloca !Type !(Maybe Operand) !Int+ | GetElementPtr !(Flag Inbounds) !Operand ![Operand]+ | Load !(Flag Volatile) !Operand !(Maybe Atomicity) !Alignment+ | Store !(Flag Volatile) !Operand !Operand !(Maybe Atomicity) !Alignment+ | Phi !(NonEmpty (Operand, Name))+ | Call !(Maybe TailCallAttribute) !CallingConvention !Operand ![Operand] -- TODO support param attributes+ -- Terminators+ | Ret !(Maybe Operand)+ | Br !Name+ | CondBr !Operand !Name !Name+ | Switch !Operand !Name ![(Operand, Name)]+ | Select !Operand !Operand !Operand+ deriving Show++newtype Terminator+ = Terminator IR+ deriving Show++renderTCA :: Renderer TailCallAttribute+renderTCA buf = \case+ Tail -> buf |># "tail"#+ NoTail -> buf |># "notail"#+ MustTail -> buf |># "musttail"#+{-# INLINABLE renderTCA #-}++renderCC :: Renderer CallingConvention+renderCC buf = \case+ C -> buf |># "ccc"#+ Fast -> buf |># "fastcc"#+{-# INLINABLE renderCC #-}++renderComparisonType :: Renderer ComparisonType+renderComparisonType buf = \case+ EQ -> buf |># "eq"#+ NE -> buf |># "ne"#+ UGT -> buf |># "ugt"#+ UGE -> buf |># "uge"#+ ULT -> buf |># "ult"#+ ULE -> buf |># "ule"#+ SGT -> buf |># "sgt"#+ SGE -> buf |># "sge"#+ SLT -> buf |># "slt"#+ SLE -> buf |># "sle"#+{-# INLINABLE renderComparisonType #-}++renderMemoryOrdering :: Renderer MemoryOrdering+renderMemoryOrdering buf = \case+ Unordered -> buf |># "unordered"#+ Monotonic -> buf |># "monotonic"#+ Acquire -> buf |># "acquire"#+ Release -> buf |># "release"#+ AcquireRelease -> buf |># "acq_rel"#+ SequentiallyConsistent -> buf |># "seq_cst"#+{-# INLINABLE renderMemoryOrdering #-}++renderSyncScope :: Renderer SynchronizationScope+renderSyncScope buf = \case+ SingleThread ->+ buf |># "syncscope(\"singlethread\")"#+ System ->+ buf+{-# INLINABLE renderSyncScope #-}++renderIR :: Renderer IR+renderIR buf = \case+ Add nuw nsw a b ->+ renderArithBinOp buf "add "# nuw nsw a b+ Mul nuw nsw a b ->+ renderArithBinOp buf "mul "# nuw nsw a b+ Sub nuw nsw a b ->+ renderArithBinOp buf "sub "# nuw nsw a b+ Udiv exact a b ->+ ((((optional exact (buf |># "udiv "#) (|># "exact "#) `renderType` typeOf a)+ |>. ' ') `renderOperand` a) |># ", "#) `renderOperand` b+ And a b ->+ ((((buf |># "and "#) `renderType` typeOf a) |>. ' ') `renderOperand` a |># ", "#) `renderOperand` b+ Or a b ->+ ((((buf |># "or "#) `renderType` typeOf a) |>. ' ') `renderOperand` a |># ", "#) `renderOperand` b+ ICmp cmp a b ->+ (((((buf |># "icmp "#) `renderComparisonType` cmp |>. ' ') `renderType` typeOf a) |>. ' ') `renderOperand` a |># ", "#) `renderOperand` b+ Trunc val to ->+ renderConvertOp buf "trunc "# val to+ Zext val to ->+ renderConvertOp buf "zext "# val to+ Bitcast val to ->+ renderConvertOp buf "bitcast "# val to+ PtrToInt val to ->+ renderConvertOp buf "ptrtoint "# val to+ Alloca ty mNumElems alignment ->+ renderMaybe+ (renderMaybe ((buf |># "alloca "#) `renderType` ty) mNumElems+ (\buf' count -> ((buf' |># ", "#) `renderType` typeOf count |>. ' ') `renderOperand` count))+ (if alignment == 0 then Nothing else Just alignment)+ (\buf' align -> buf' |># ", align "# |>$ align)+ GetElementPtr inbounds pointer indices ->+ case typeOf pointer of+ ty@(PointerType innerTy) ->+ commas (((optional inbounds (buf |># "getelementptr "#) (|># "inbounds "#) `renderType` innerTy |># ", "#) `renderType` ty |>. ' ')+ `renderOperand` pointer |># ", "#) indices prettyIndex+ _ ->+ buf |> error "Operand given to `getelementptr` that is not a pointer!"+ where+ prettyIndex :: Buffer %1 -> Operand -> Buffer+ prettyIndex buf' i = (renderType buf' (typeOf i) |>. ' ') `renderOperand` i+ Load volatile addr atomicity alignment ->+ case atomicity of+ Nothing ->+ withAlignment alignment+ ((((optional volatile (buf |># "load "#) (|># "volatile "#)+ `renderType` resultTy) |># ", "#) `renderType` ptrTy |>. ' ') `renderOperand` addr)+ Just (syncScope, memoryOrdering) ->+ withAlignment alignment+ ((((((optional volatile (buf |># "load atomic "#) (|># "volatile "#)+ `renderType` resultTy) |># ", "#) `renderType` ptrTy |>. ' ') `renderOperand` addr |>. ' ')+ `renderSyncScope` syncScope |>. ' ') `renderMemoryOrdering` memoryOrdering)+ where+ ptrTy = typeOf addr+ resultTy = case ptrTy of+ PointerType ty -> ty+ _ -> error "Malformed AST, expected pointer type."+ Store volatile addr value atomicity alignment ->+ case atomicity of+ Nothing ->+ withAlignment alignment+ ((((optional volatile (buf |># "store "#) (|># "volatile "#) `renderType` ty |>. ' ') `renderOperand` value |># ", "#)+ `renderType` ptrTy |>. ' ') `renderOperand` addr)+ Just (syncScope, memoryOrdering) ->+ withAlignment alignment+ ((((((optional volatile (buf |># "store atomic "#) (|># "volatile "#) `renderType` ty |>. ' ') `renderOperand` value |># ", "#)+ `renderType` ptrTy |>. ' ') `renderOperand` addr |>. ' ') `renderSyncScope` syncScope |>. ' ') `renderMemoryOrdering` memoryOrdering)+ where+ ty = typeOf value+ ptrTy = PointerType ty+ Phi cases@((val, _) :| _) ->+ commas ((buf |># "phi "#) `renderType` typeOf val |>. ' ') (NE.toList cases) renderPhiCase+ where+ renderPhiCase :: Renderer (Operand, Name)+ renderPhiCase buf' (value, name) =+ brackets buf' (\buf'' -> (renderOperand buf'' value |># ", %"#) `renderName` name)+ Call tcAttr cc fn args ->+ (((renderMaybe buf tcAttr (\buf' tca -> renderTCA buf' tca |>. ' ')+ |># "call "#) `renderCC` cc |>. ' ') `renderType` resultType |>. ' ')+ `renderOperand` fn `renderArgs` args+ where+ resultType = case typeOf fn of+ PointerType (FunctionType retTy _) -> retTy+ FunctionType retTy _ -> retTy+ _ -> error "Malformed AST, expected function type."+ renderArgs :: Renderer [Operand]+ renderArgs buf' args' = tupled buf' args' renderArg+ renderArg :: Renderer Operand+ renderArg buf' arg =+ (renderType buf' (typeOf arg) |>. ' ') `renderOperand` arg+ Ret term -> case term of+ Nothing ->+ buf |># "ret void"#+ Just operand ->+ ((buf |># "ret "#) `renderType` typeOf operand |>. ' ') `renderOperand` operand+ Br blockName ->+ (buf |># "br label %"#) `renderName` blockName+ CondBr cond trueLabel falseLabel ->+ (((buf |># "br i1 "#) `renderOperand` cond+ |># ", label %"#) `renderName` trueLabel+ |># ", label %"#) `renderName` falseLabel+ Switch val defaultLabel cases ->+ brackets ((((buf |># "switch "#) `renderType` typeOf val |>. ' ') `renderOperand` val |># ", label %"#) `renderName` defaultLabel |>. ' ')+ (\buf' -> hsep buf' cases renderCase)+ where+ renderCase :: Renderer (Operand, Name)+ renderCase buf' (caseVal, label) =+ ((renderType buf' (typeOf caseVal) |>. ' ') `renderOperand` caseVal |># ", label %"#) `renderName` label+ Select c t f ->+ ((((((buf |># "select "#) `renderType` typeOf c |>. ' ') `renderOperand` c |># ", "#)+ `renderType` typeOf t |>. ' ') `renderOperand` t |># ", "#)+ `renderType` typeOf f |>. ' ') `renderOperand` f+ where+ withAlignment :: Word32 -> Buffer %1 -> Buffer+ withAlignment alignment buf' =+ if alignment == 0+ then buf'+ else buf' |># ", align "# |>$ alignment+{-# INLINABLE renderIR #-}++renderArithBinOp :: Buffer %1 -> Addr# -> Flag NUW -> Flag NSW -> Operand -> Operand -> Buffer+renderArithBinOp buf opName nuw nsw a b =+ (((optional nsw (optional nuw+ (buf |># opName) (|># "nuw "#)) (|># "nsw "#) `renderType` typeOf a) |>. ' ') `renderOperand` a |># ", "#) `renderOperand` b+{-# INLINABLE renderArithBinOp #-}++renderConvertOp :: Buffer %1 -> Addr# -> Operand -> Type -> Buffer+renderConvertOp buf opName val to =+ ((((buf |># opName) `renderType` typeOf val) |>. ' ') `renderOperand` val |># " to "#) `renderType` to+{-# INLINABLE renderConvertOp #-}
+ lib/LLVM/Codegen/IRBuilder.hs view
@@ -0,0 +1,479 @@+{-# LANGUAGE RecursiveDo, PolyKinds, RoleAnnotations #-}++module LLVM.Codegen.IRBuilder+ ( IRBuilderT+ , IRBuilder+ , block+ , blockNamed+ , emitBlockStart+ , emitInstr+ , emitInstrVoid+ , emitTerminator+ , BasicBlock(..)+ , runIRBuilderT+ , runIRBuilder+ , MonadIRBuilder(..)++ , add+ , mul+ , sub+ , udiv+ , and+ , or+ , trunc+ , zext+ , ptrtoint+ , bitcast+ , ptrcast+ , icmp+ , alloca+ , gep+ , load+ , store+ , phi+ , call+ , ret+ , retVoid+ , br+ , condBr+ , switch+ , select++ , eq+ , ne+ , sge+ , sgt+ , sle+ , slt+ , uge+ , ugt+ , ule+ , ult+ , if'+ , loop+ , loopWhile+ , loopFor+ , pointerDiff+ , not'+ , Signedness(..)+ , minimum'+ , allocate+ , Path(..), (->>), mkPath+ , addr, deref, assign, update, increment, copy, swap++ , bit+ , int8+ , int16+ , int32+ , int64+ , intN+ , nullPtr+ ) where++import Prelude hiding (EQ, and, or)+import GHC.Stack+import Control.Monad.Fix+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty(..))+import Data.Word+import LLVM.Codegen.Name+import LLVM.Codegen.Operand+import LLVM.Codegen.Type+import LLVM.Codegen.IR+import LLVM.Codegen.IRBuilder.Monad+import LLVM.Codegen.ModuleBuilder+++-- Helpers for generating instructions:++add :: (MonadIRBuilder m, HasCallStack) => Operand -> Operand -> m Operand+add lhs rhs =+ emitInstr (typeOf lhs) $ Add Off Off lhs rhs+{-# INLINEABLE add #-}++mul :: (MonadIRBuilder m, HasCallStack) => Operand -> Operand -> m Operand+mul lhs rhs =+ emitInstr (typeOf lhs) $ Mul Off Off lhs rhs+{-# INLINEABLE mul #-}++sub :: (MonadIRBuilder m, HasCallStack) => Operand -> Operand -> m Operand+sub lhs rhs =+ emitInstr (typeOf lhs) $ Sub Off Off lhs rhs+{-# INLINEABLE sub #-}++udiv :: (MonadIRBuilder m, HasCallStack) => Operand -> Operand -> m Operand+udiv lhs rhs =+ emitInstr (typeOf lhs) $ Udiv Off lhs rhs+{-# INLINEABLE udiv #-}++and :: (MonadIRBuilder m, HasCallStack) => Operand -> Operand -> m Operand+and lhs rhs =+ emitInstr (typeOf lhs) $ And lhs rhs+{-# INLINEABLE and #-}++or :: (MonadIRBuilder m, HasCallStack) => Operand -> Operand -> m Operand+or lhs rhs =+ emitInstr (typeOf lhs) $ Or lhs rhs+{-# INLINEABLE or #-}++trunc :: (MonadIRBuilder m, HasCallStack) => Operand -> Type -> m Operand+trunc val ty =+ emitInstr ty $ Trunc val ty+{-# INLINEABLE trunc #-}++zext :: (MonadIRBuilder m, HasCallStack) => Operand -> Type -> m Operand+zext val ty =+ emitInstr ty $ Zext val ty+{-# INLINEABLE zext #-}++ptrtoint :: (MonadIRBuilder m, HasCallStack) => Operand -> Type -> m Operand+ptrtoint val ty =+ emitInstr ty $ PtrToInt val ty+{-# INLINEABLE ptrtoint #-}++-- At the moment not useful because of introduction of opaque pointers.+-- Will become more useful once float or vector types are added again.+bitcast :: (MonadIRBuilder m, HasCallStack) => Operand -> Type -> m Operand+bitcast val ty =+ emitInstr ty $ Bitcast val ty+{-# INLINEABLE bitcast #-}++-- Casts a pointer to be a pointer containing type "ty".+-- This helper function is introduced to smooth the transition between+-- LLVM14 -> LLVM15+ (opaque pointer migration).+-- All bitcasts of pointers should be replaced with ptrcasts+ptrcast :: Type -> Operand -> Operand+ptrcast ty = \case+ LocalRef (PointerType _) name ->+ LocalRef (PointerType ty) name+ ConstantOperand (NullPtr _) ->+ ConstantOperand $ NullPtr ty+ _ ->+ error "'ptrcast' is only supported for pointer operands."+{-# INLINEABLE ptrcast #-}++icmp :: (MonadIRBuilder m, HasCallStack) => ComparisonType -> Operand -> Operand -> m Operand+icmp cmp a b =+ emitInstr i1 $ ICmp cmp a b+{-# INLINEABLE icmp #-}++eq, ne, sge, sgt, sle, slt, uge, ugt, ule, ult+ :: (MonadIRBuilder m, HasCallStack) => Operand -> Operand -> m Operand+eq = icmp EQ+ne = icmp NE+sge = icmp SGE+sgt = icmp SGT+sle = icmp SLE+slt = icmp SLT+uge = icmp UGE+ugt = icmp UGT+ule = icmp ULE+ult = icmp ULT+{-# INLINABLE eq #-}+{-# INLINABLE ne #-}+{-# INLINABLE sge #-}+{-# INLINABLE sgt #-}+{-# INLINABLE sle #-}+{-# INLINABLE slt #-}+{-# INLINABLE uge #-}+{-# INLINABLE ugt #-}+{-# INLINABLE ule #-}+{-# INLINABLE ult #-}++alloca :: (MonadIRBuilder m, HasCallStack) => Type -> Maybe Operand -> Int -> m Operand+alloca ty numElems alignment =+ emitInstr (ptr ty) $ Alloca ty numElems alignment+{-# INLINEABLE alloca #-}++gep :: (HasCallStack, MonadModuleBuilder m, MonadIRBuilder m)+ => Operand -> [Operand] -> m Operand+gep operand indices = do+ resultType <- computeGepType (typeOf operand) indices+ case resultType of+ Left err -> error err+ Right ty ->+ emitInstr ty $ GetElementPtr Off operand indices+{-# INLINEABLE gep #-}++computeGepType :: (MonadModuleBuilder m, HasCallStack) => Type -> [Operand] -> m (Either String Type)+computeGepType ty [] = pure $ Right $ PointerType ty+computeGepType (PointerType ty) (_ : idxs) =+ case (ty, null idxs) of+ -- If you want to load something from e.g. i8***, you need to gep + load for each pointer indirection!+ (PointerType{}, False) -> pure $ Left "Opaque pointers support only one gep offset."+ _ -> computeGepType ty idxs+computeGepType (StructureType _ elTys) (ConstantOperand (Int 32 val):is) =+ computeGepType (elTys !! fromIntegral val) is+computeGepType (StructureType _ _) (i:_) =+ pure $ Left $ "Indices into structures should be 32-bit integer constants. (Malformed AST): " <> show i+computeGepType (ArrayType _ elTy) (_:is) = computeGepType elTy is+computeGepType (NamedTypeReference n) is =+ lookupType n >>= \case+ Nothing -> pure $ Left $ "Couldn’t resolve typedef for: " <> show n+ Just ty -> computeGepType ty is+computeGepType ty _ =+ pure $ Left $ "Expecting aggregate type. (Malformed AST): " <> show ty+{-# INLINEABLE computeGepType #-}++load :: (HasCallStack, MonadIRBuilder m) => Operand -> Alignment -> m Operand+load address align =+ case typeOf address of+ PointerType ty ->+ emitInstr ty $ Load Off address Nothing align+ t ->+ error $ "Malformed AST: Expected a pointer type" <> show t+{-# INLINEABLE load #-}++store :: (MonadIRBuilder m, HasCallStack) => Operand -> Alignment -> Operand -> m ()+store address align value =+ emitInstrVoid $ Store Off address value Nothing align+{-# INLINEABLE store #-}++phi :: (HasCallStack, MonadIRBuilder m) => [(Operand, Name)] -> m Operand+phi cases+ | null cases = error "phi instruction should always have > 0 cases!"+ | otherwise =+ let neCases = NE.fromList cases+ ty = typeOf $ fst $ NE.head neCases+ in emitInstr ty $ Phi neCases+{-# INLINEABLE phi #-}++call :: (HasCallStack, MonadIRBuilder m) => Operand -> [Operand] -> m Operand+call fn args = case typeOf fn of+ FunctionType retTy _->+ emitCallInstr retTy+ PointerType (FunctionType retTy _) ->+ emitCallInstr retTy+ _ -> error "Malformed AST, expected function type in 'call' instruction"+ where+ emitCallInstr resultTy =+ if resultTy == VoidType+ then do+ emitInstrVoid $ Call Nothing C fn args+ pure $ ConstantOperand $ Undef void -- Invalid, but isn't rendered anyway+ else emitInstr resultTy $ Call Nothing C fn args+{-# INLINEABLE call #-}++ret :: (HasCallStack, MonadIRBuilder m) => Operand -> m ()+ret val =+ emitTerminator (Terminator (Ret (Just val)))+{-# INLINEABLE ret #-}++retVoid :: (HasCallStack, MonadIRBuilder m) => m ()+retVoid =+ emitTerminator (Terminator (Ret Nothing))+{-# INLINEABLE retVoid #-}++br :: (MonadIRBuilder m, HasCallStack) => Name -> m ()+br label =+ emitTerminator (Terminator (Br label))+{-# INLINEABLE br #-}++condBr :: (HasCallStack, MonadIRBuilder m) => Operand -> Name -> Name -> m ()+condBr cond trueLabel falseLabel =+ emitTerminator (Terminator (CondBr cond trueLabel falseLabel))+{-# INLINEABLE condBr #-}++switch :: (HasCallStack, MonadIRBuilder m) => Operand -> Name -> [(Operand, Name)] -> m ()+switch value defaultDest dests =+ emitTerminator $ Terminator $ Switch value defaultDest dests+{-# INLINEABLE switch #-}++select :: (HasCallStack, MonadIRBuilder m) => Operand -> Operand -> Operand -> m Operand+select c t f =+ emitInstr (typeOf t) $ Select c t f+{-# INLINEABLE select #-}++if' :: (HasCallStack, MonadIRBuilder m, MonadFix m)+ => Operand -> m a -> m ()+if' condition asm = mdo+ condBr condition ifBlock end+ ifBlock <- blockNamed "if"+ _ <- asm+ br end+ end <- blockNamed "end_if"+ pure ()+{-# INLINEABLE if' #-}++loop :: (HasCallStack, MonadIRBuilder m, MonadFix m) => m a -> m ()+loop asm = mdo+ br begin+ begin <- blockNamed "loop"+ _ <- asm+ br begin+{-# INLINEABLE loop #-}++loopWhile :: (HasCallStack, MonadIRBuilder m, MonadFix m)+ => m Operand -> m a -> m ()+loopWhile condition asm = mdo+ br begin+ begin <- blockNamed "while_begin"+ result <- condition+ condBr result body end+ body <- blockNamed "while_body"+ _ <- asm+ br begin+ end <- blockNamed "while_end"+ pure ()+{-# INLINEABLE loopWhile #-}++loopFor :: (HasCallStack, MonadModuleBuilder m, MonadIRBuilder m, MonadFix m)+ => Operand+ -> (Operand -> m Operand)+ -> (Operand -> m Operand)+ -> (Operand -> m a)+ -> m ()+loopFor beginValue condition post asm = mdo+ start <- currentBlock+ br begin+ begin <- blockNamed "for_begin"+ loopValue <- phi [(beginValue, start), (updatedValue, bodyEnd)]+ result <- condition loopValue+ condBr result bodyStart end+ bodyStart <- blockNamed "for_body"+ _ <- asm loopValue+ updatedValue <- post loopValue+ bodyEnd <- currentBlock+ br begin+ end <- blockNamed "for_end"+ pure ()+{-# INLINEABLE loopFor #-}++-- NOTE: diff is in bytes! (Different compared to C and C++)+pointerDiff :: (HasCallStack, MonadIRBuilder m)+ => Type -> Operand -> Operand -> m Operand+pointerDiff ty a b = do+ a' <- ptrtoint a i64+ b' <- ptrtoint b i64+ result <- sub a' b'+ if ty == i64+ then pure result+ else trunc result ty+{-# INLINEABLE pointerDiff #-}++-- | Calculates the logical not of a boolean 'Operand'.+-- NOTE: This assumes the 'Operand' is of type 'i1', this is not checked!+-- Passing in an argument of another width will lead to a crash in LLVM.+not' :: (HasCallStack, MonadIRBuilder m)+ => Operand -> m Operand+not' bool =+ select bool (bit 0) (bit 1)+{-# INLINEABLE not' #-}++data Signedness = Signed | Unsigned++-- NOTE: No check is made if the 2 operands have the same 'Type'!+minimum' :: (HasCallStack, MonadIRBuilder m)+ => Signedness -> Operand -> Operand -> m Operand+minimum' sign a b = do+ let inst = case sign of+ Signed -> slt+ Unsigned -> ult+ isLessThan <- inst a b+ select isLessThan a b+{-# INLINEABLE minimum' #-}++allocate :: (HasCallStack, MonadIRBuilder m) => Type -> Operand -> m Operand+allocate ty beginValue = do+ value <- alloca ty Nothing 0+ store value 0 beginValue+ pure value+{-# INLINEABLE allocate #-}++newtype Path (a :: k) (b :: k)+ = Path (NonEmpty Operand)+ deriving (Eq, Show)+type role Path nominal nominal++mkPath :: [Operand] -> Path a b+mkPath path = Path (int32 0 :| path)++(->>) :: Path a b -> Path b c -> Path a c+Path a2b ->> Path b2c =+ let b2c' = if NE.head b2c == int32 0+ then NE.tail b2c+ else NE.toList b2c+ in Path $ NE.head a2b :| (NE.tail a2b ++ b2c')++addr :: (MonadModuleBuilder m, MonadIRBuilder m, HasCallStack)+ => Path a b -> Operand -> m Operand+addr path p = gep p (pathToIndices path)+ where+ pathToIndices :: Path a b -> [Operand]+ pathToIndices (Path indices) =+ NE.toList indices+{-# INLINEABLE addr #-}++deref :: (MonadModuleBuilder m, MonadIRBuilder m, HasCallStack)+ => Path a b -> Operand -> m Operand+deref path p = do+ address <- addr path p+ load address 0+{-# INLINEABLE deref #-}++assign :: (MonadModuleBuilder m, MonadIRBuilder m, HasCallStack)+ => Path a b -> Operand -> Operand -> m ()+assign path p value = do+ dstAddr <- addr path p+ store dstAddr 0 value+{-# INLINEABLE assign #-}++update :: (MonadModuleBuilder m, MonadIRBuilder m, HasCallStack)+ => Path a b+ -> Operand+ -> (Operand -> m Operand)+ -> m ()+update path p f = do+ dstAddr <- addr path p+ store dstAddr 0 =<< f =<< load dstAddr 0+{-# INLINEABLE update #-}++increment :: (MonadModuleBuilder m, MonadIRBuilder m, HasCallStack)+ => (Integer -> Operand) -> Path a b -> Operand -> m ()+increment ty path p =+ update path p (add (ty 1))+{-# INLINEABLE increment #-}++copy :: (MonadModuleBuilder m, MonadIRBuilder m, HasCallStack)+ => Path a b -> Operand -> Operand -> m ()+copy path src dst = do+ value <- deref path src+ assign path dst value+{-# INLINEABLE copy #-}++swap :: (MonadModuleBuilder m, MonadIRBuilder m, HasCallStack)+ => Path a b -> Operand -> Operand -> m ()+swap path lhs rhs = do+ tmp <- deref path lhs+ copy path rhs lhs+ assign path rhs tmp+{-# INLINEABLE swap #-}+++bit :: Integer -> Operand+bit b =+ intN 1 $ if b == 0 then 0 else 1++int8 :: Integer -> Operand+int8 =+ intN 8++int16 :: Integer -> Operand+int16 =+ intN 16++int32 :: Integer -> Operand+int32 =+ intN 32++int64 :: Integer -> Operand+int64 =+ intN 64++intN :: Word32 -> Integer -> Operand+intN bits value =+ ConstantOperand $ Int bits value++nullPtr :: Type -> Operand+nullPtr =+ ConstantOperand . NullPtr
+ lib/LLVM/Codegen/IRBuilder/Monad.hs view
@@ -0,0 +1,306 @@+{-# LANGUAGE TypeFamilies, RankNTypes, MultiParamTypeClasses, UndecidableInstances, BangPatterns, TypeOperators #-}++module LLVM.Codegen.IRBuilder.Monad+ ( IRBuilderT+ , IRBuilder+ , runIRBuilderT+ , runIRBuilder+ , MonadIRBuilder(..)+ , BasicBlock(..)+ , block+ , blockNamed+ , emitBlockStart+ , emitInstr+ , emitInstrVoid+ , emitTerminator+ , renderBasicBlock+ , freshName+ ) where++-- NOTE: this module only exists to solve a cyclic import++import Prelude hiding (and)+import Control.Arrow hiding ((<+>))+import Control.Monad.State.Lazy (StateT(..), MonadState, modify)+import qualified Control.Monad.State.Strict as StrictState+import qualified Control.Monad.State.Lazy as LazyState+import qualified Control.Monad.RWS.Lazy as LazyRWS+import qualified Control.Monad.RWS.Strict as StrictRWS+import Control.Monad+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.Except+import Control.Monad.Morph+import Control.Monad.Fix+import Data.Functor.Identity+import qualified Data.Text as T+import qualified Data.DList as DList+import Data.DList (DList)+import qualified Data.Map as M+import Data.Map (Map)+import Data.Maybe+import Data.Monoid+import LLVM.Codegen.Operand+import LLVM.Codegen.IR+import LLVM.Codegen.Type+import LLVM.Codegen.Name+import LLVM.Pretty+++data BasicBlock+ = BB+ { bbName :: !Name+ , bbInstructions :: !(DList (Maybe Operand, IR))+ , bbTerminator :: !Terminator+ } deriving Show++data PartialBlock+ = PartialBlock+ { pbName :: !Name+ , pbInstructions :: !(DList (Maybe Operand, IR))+ , pbTerminator :: !(First Terminator)+ , pbNumInstrs :: !Int+ }++data IRBuilderState+ = IRBuilderState+ { allocas :: !(DList (Maybe Operand, IR))+ , basicBlocks :: !(DList BasicBlock)+ , currentPartialBlock :: !PartialBlock+ , operandCounter :: !Int+ , nameMap :: !(Map T.Text Int)+ }++newtype IRBuilderT m a+ = IRBuilderT { unIRBuilderT :: StateT IRBuilderState m a }+ deriving ( Functor, Applicative, Monad, MonadFix, MonadIO+ , MonadError e+ )+ via StateT IRBuilderState m++instance MonadReader r m => MonadReader r (IRBuilderT m) where+ ask = lift ask+ {-# INLINEABLE ask #-}+ local = mapIRBuilderT . local+ {-# INLINEABLE local #-}++-- TODO MonadWriter++mapIRBuilderT :: (Monad m, Monad n) => (m a -> n a) -> IRBuilderT m a -> IRBuilderT n a+mapIRBuilderT f (IRBuilderT inner) =+ IRBuilderT $ do+ s <- LazyState.get+ LazyState.mapStateT (g s) inner+ where+ g s = fmap (,s) . f . fmap fst+{-# INLINEABLE mapIRBuilderT #-}++instance MonadState s m => MonadState s (IRBuilderT m) where+ state = lift . StrictState.state+ {-# INLINEABLE state #-}++instance MonadTrans IRBuilderT where+ lift = IRBuilderT . lift+ {-# INLINEABLE lift #-}++instance MFunctor IRBuilderT where+ hoist nat = IRBuilderT . hoist nat . unIRBuilderT+ {-# INLINEABLE hoist #-}++type IRBuilder = IRBuilderT Identity++runIRBuilderT :: Monad m => IRBuilderT m a -> m (a, [BasicBlock])+runIRBuilderT (IRBuilderT m) = do+ let partialBlock = PartialBlock (Name "start") mempty mempty 0+ result = runStateT m (IRBuilderState mempty mempty partialBlock 0 mempty)+ fmap (second getBlocks) result+ where+ getBlocks irState =+ case blocks of+ [] -> []+ (firstBlk:restBlks) ->+ let firstBlk' = firstBlk { bbInstructions = DList.append allocations (bbInstructions firstBlk) }+ in (firstBlk':restBlks)+ where+ previousBlocks = DList.apply (basicBlocks irState) mempty+ currentBlk = currentPartialBlock irState+ blocks = previousBlocks <> [partialBlockToBasicBlock currentBlk]+ allocations = allocas irState+{-# INLINEABLE runIRBuilderT #-}++runIRBuilder :: IRBuilder a -> (a, [BasicBlock])+runIRBuilder = runIdentity . runIRBuilderT+{-# INLINEABLE runIRBuilder #-}++partialBlockToBasicBlock :: PartialBlock -> BasicBlock+partialBlockToBasicBlock pb =+ let currentTerm = fromMaybe (Terminator $ Ret Nothing) $ getFirst $ pbTerminator pb+ in BB (pbName pb) (pbInstructions pb) currentTerm+{-# INLINEABLE partialBlockToBasicBlock #-}++block :: (MonadIRBuilder m) => m Name+block = do+ blockName <- freshName (Just "block")+ emitBlockStart blockName+ pure blockName+{-# INLINEABLE block #-}++blockNamed :: (MonadIRBuilder m) => T.Text -> m Name+blockNamed blkName = do+ blockName <- freshName (Just blkName)+ emitBlockStart blockName+ pure blockName+{-# INLINEABLE blockNamed #-}++emitBlockStart :: (MonadIRBuilder m) => Name -> m ()+emitBlockStart blockName =+ modifyIRBuilderState $ \s ->+ let currBlock = currentPartialBlock s+ hasntStartedBlock = (pbNumInstrs currBlock == 0) && isNothing (getFirst (pbTerminator currBlock))+ blocks = basicBlocks s+ -- If the current block is empty:+ -- Insert a dummy basic block that jumps directly to the next block, to avoid continuity errors.+ -- Normally, LLVM should optimize this away since it is semantically a no-op.+ -- Otherwise:+ -- Append the current block to the existing list of blocks.+ --+ -- NOTE: This is different behavior compared to the llvm-hs-pure library,+ -- but this avoids a lot of partial functions!+ newBlock =+ if hasntStartedBlock+ then BB (pbName currBlock) mempty (Terminator $ Br blockName)+ else partialBlockToBasicBlock currBlock+ in s { basicBlocks = DList.snoc blocks newBlock+ , currentPartialBlock = PartialBlock blockName mempty mempty 0+ }+{-# INLINEABLE emitBlockStart #-}++-- NOTE: Only used internally, this creates an unassigned operand+mkOperand :: (MonadIRBuilder m) => Type -> m Operand+mkOperand ty = LocalRef ty <$!> freshUnnamed+{-# INLINEABLE mkOperand #-}++freshName :: MonadIRBuilder m => Maybe T.Text -> m Name+freshName = \case+ Nothing -> freshUnnamed+ Just suggestion -> do+ nameMapping <- nameMap <$> getIRBuilderState+ let !mCount = M.lookup suggestion nameMapping+ !count = fromMaybe 0 mCount+ !newMapping = M.insert suggestion (count + 1) nameMapping+ modifyIRBuilderState $ \s -> s { nameMap = newMapping }+ pure $! Name $! suggestion <> "_" <> T.pack (show count)+{-# INLINEABLE freshName #-}++freshUnnamed :: MonadIRBuilder m => m Name+freshUnnamed = do+ !ctr <- operandCounter <$> getIRBuilderState+ let !newCount = ctr + 1+ modifyIRBuilderState $ \s -> s { operandCounter = newCount }+ pure $! Generated ctr+{-# INLINEABLE freshUnnamed #-}++emitInstr :: (MonadIRBuilder m) => Type -> IR -> m Operand+emitInstr ty = \case+ instr@(Alloca {}) -> do+ -- For performant code, all alloca instructions should be at the start of the function!+ -- https://llvm.org/docs/Frontend/PerformanceTips.html#use-of-allocas+ -- (A custom operand name is only used here to avoid having to re-number all operands.)+ operand <- LocalRef ty <$!> freshName (Just "stack.ptr")+ addAlloca operand instr+ pure operand+ instr -> do+ operand <- mkOperand ty+ addInstrToCurrentBlock (Just operand) instr+ pure operand+{-# INLINABLE emitInstr #-}++emitInstrVoid :: MonadIRBuilder m => IR -> m ()+emitInstrVoid =+ addInstrToCurrentBlock Nothing+{-# INLINABLE emitInstrVoid #-}++addInstrToCurrentBlock :: MonadIRBuilder m => Maybe Operand -> IR -> m ()+addInstrToCurrentBlock operand instr =+ modifyCurrentBlock $ \blk ->+ let instrs = DList.snoc (pbInstructions blk) (operand, instr)+ in blk { pbInstructions = instrs, pbNumInstrs = pbNumInstrs blk + 1 }+{-# INLINEABLE addInstrToCurrentBlock #-}++addAlloca :: MonadIRBuilder m => Operand -> IR -> m ()+addAlloca operand instr =+ modifyIRBuilderState $ \s ->+ s { allocas = DList.snoc (allocas s) (Just operand, instr) }+{-# INLINEABLE addAlloca #-}++emitTerminator :: MonadIRBuilder m => Terminator -> m ()+emitTerminator term =+ modifyCurrentBlock $ \blk ->+ blk { pbTerminator = pbTerminator blk <> First (Just term) }+{-# INLINABLE emitTerminator #-}++modifyCurrentBlock :: MonadIRBuilder m => (PartialBlock -> PartialBlock) -> m ()+modifyCurrentBlock f =+ modifyIRBuilderState $ \s ->+ s { currentPartialBlock = f (currentPartialBlock s) }+{-# INLINEABLE modifyCurrentBlock #-}++class Monad m => MonadIRBuilder m where+ getIRBuilderState :: m IRBuilderState++ modifyIRBuilderState :: (IRBuilderState -> IRBuilderState) -> m ()++ currentBlock :: m Name++ default getIRBuilderState+ :: (MonadTrans t, MonadIRBuilder m1, m ~ t m1)+ => m IRBuilderState+ getIRBuilderState = lift getIRBuilderState+ {-# INLINEABLE getIRBuilderState #-}++ default modifyIRBuilderState+ :: (MonadTrans t, MonadIRBuilder m1, m ~ t m1)+ => (IRBuilderState -> IRBuilderState)+ -> m ()+ modifyIRBuilderState = lift . modifyIRBuilderState+ {-# INLINEABLE modifyIRBuilderState #-}++ default currentBlock+ :: (MonadTrans t, MonadIRBuilder m1, m ~ t m1)+ => m Name+ currentBlock = lift currentBlock+ {-# INLINEABLE currentBlock #-}++instance Monad m => MonadIRBuilder (IRBuilderT m) where+ getIRBuilderState = IRBuilderT LazyState.get+ {-# INLINEABLE getIRBuilderState #-}++ modifyIRBuilderState = IRBuilderT . modify+ {-# INLINEABLE modifyIRBuilderState #-}++ currentBlock =+ IRBuilderT $ LazyState.gets (pbName . currentPartialBlock)+ {-# INLINEABLE currentBlock #-}++instance MonadIRBuilder m => MonadIRBuilder (StrictState.StateT s m)+instance MonadIRBuilder m => MonadIRBuilder (LazyState.StateT s m)+instance (MonadIRBuilder m, Monoid w) => MonadIRBuilder (StrictRWS.RWST r w s m)+instance (MonadIRBuilder m, Monoid w) => MonadIRBuilder (LazyRWS.RWST r w s m)+instance MonadIRBuilder m => MonadIRBuilder (ReaderT r m)+instance (MonadIRBuilder m, Monoid w) => MonadIRBuilder (WriterT w m)+instance MonadIRBuilder m => MonadIRBuilder (ExceptT e m)++renderBasicBlock :: Renderer BasicBlock+renderBasicBlock buf (BB name stmts (Terminator term)) =+ if null stmts+ then (renderName buf name |># ":\n "#) `renderIR` term+ else (vsep (renderName buf name |># ":\n"#) stmts' renderStmt |># "\n "#) `renderIR` term+ where+ stmts' = DList.apply stmts []+ renderStmt :: Buffer %1 -> (Maybe Operand, IR) -> Buffer+ renderStmt buf' (mOperand, instr) =+ withIndent buf' (\buf'' -> renderStmt' buf'' mOperand instr)+ renderStmt' :: Buffer %1 -> Maybe Operand -> IR -> Buffer+ renderStmt' buf' mOperand instr =+ renderMaybe buf' mOperand (\buf'' operand -> buf'' `renderOperand` operand |># " = "#) `renderIR` instr+{-# INLINABLE renderBasicBlock #-}
+ lib/LLVM/Codegen/ModuleBuilder.hs view
@@ -0,0 +1,332 @@+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, UndecidableInstances, TypeOperators #-}++module LLVM.Codegen.ModuleBuilder+ ( ModuleBuilderT+ , ModuleBuilder+ , runModuleBuilderT+ , runModuleBuilder+ , MonadModuleBuilder+ , Module(..)+ , Definition(..)+ , ParameterName(..)+ , FunctionAttribute(..)+ , function+ , global+ , globalUtf8StringPtr+ , extern+ , typedef+ , opaqueTypedef+ , getTypedefs+ , lookupType+ , withFunctionAttributes+ , renderModule+ ) where++import GHC.Stack+import Control.Monad.State.Lazy (StateT(..), MonadState, State, execStateT, modify, gets)+import qualified Control.Monad.State.Strict as StrictState+import qualified Control.Monad.State.Lazy as LazyState+import qualified Control.Monad.RWS.Lazy as LazyRWS+import qualified Control.Monad.RWS.Strict as StrictRWS+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.Except+import Control.Monad.Morph+import Control.Monad.Fix+import Data.DList (DList)+import Data.Map (Map)+import Data.String+import qualified Data.DList as DList+import qualified Data.Map as Map+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.ByteString as BS+import Data.Functor.Identity+import LLVM.Codegen.IRBuilder.Monad+import LLVM.Codegen.Operand+import LLVM.Codegen.Type+import LLVM.Codegen.Name+import LLVM.Codegen.Flag+import LLVM.Codegen.IR+import LLVM.Pretty+++newtype Module+ = Module [Definition]++data ParameterName+ = ParameterName !T.Text+ | NoParameterName+ deriving Show++instance IsString ParameterName where+ fromString = ParameterName . fromString++data FunctionAttribute+ = WasmExportName !T.Text+ | AlwaysInline+ -- Add more as needed..+ deriving Show++data Global+ = GlobalVariable !Name !Type !Constant+ | Function !Name !Type ![(Type, ParameterName)] ![FunctionAttribute] ![BasicBlock]+ deriving Show++data Typedef+ = Opaque+ | Clear !Type+ deriving Show++data Definition+ = GlobalDefinition !Global+ | TypeDefinition !Name !Typedef+ deriving Show++data ModuleBuilderState+ = ModuleBuilderState+ { definitions :: !(DList Definition)+ , types :: !(Map Name Type)+ , defaultFunctionAttributes :: ![FunctionAttribute]+ }++newtype ModuleBuilderT m a+ = ModuleBuilderT { unModuleBuilderT :: StateT ModuleBuilderState m a }+ deriving ( Functor, Applicative, Monad, MonadFix, MonadIO+ , MonadError e+ )+ via StateT ModuleBuilderState m++type ModuleBuilder = ModuleBuilderT Identity++instance MonadTrans ModuleBuilderT where+ lift = ModuleBuilderT . lift+ {-# INLINEABLE lift #-}++instance MonadReader r m => MonadReader r (ModuleBuilderT m) where+ ask = lift ask+ {-# INLINEABLE ask #-}+ local = mapModuleBuilderT . local+ {-# INLINEABLE local #-}++mapModuleBuilderT :: (Functor m, Monad n) => (m a -> n a) -> ModuleBuilderT m a -> ModuleBuilderT n a+mapModuleBuilderT f (ModuleBuilderT inner) =+ ModuleBuilderT $ do+ s <- LazyState.get+ LazyState.mapStateT (g s) inner+ where+ g s = fmap (,s) . f . fmap fst+{-# INLINEABLE mapModuleBuilderT #-}++instance MonadState s m => MonadState s (ModuleBuilderT m) where+ state = lift . LazyState.state+ {-# INLINEABLE state #-}++instance MFunctor ModuleBuilderT where+ hoist nat = ModuleBuilderT . hoist nat . unModuleBuilderT+ {-# INLINEABLE hoist #-}++class Monad m => MonadModuleBuilder m where+ liftModuleBuilderState :: State ModuleBuilderState a -> m a++ default liftModuleBuilderState+ :: (MonadTrans t, MonadModuleBuilder m1, m ~ t m1)+ => State ModuleBuilderState a+ -> m a+ liftModuleBuilderState = lift . liftModuleBuilderState+ {-# INLINEABLE liftModuleBuilderState #-}++instance Monad m => MonadModuleBuilder (ModuleBuilderT m) where+ liftModuleBuilderState (StateT s) =+ ModuleBuilderT $ StateT $ pure . runIdentity . s+ {-# INLINEABLE liftModuleBuilderState #-}++instance MonadModuleBuilder m => MonadModuleBuilder (IRBuilderT m)+instance MonadModuleBuilder m => MonadModuleBuilder (StrictState.StateT s m)+instance MonadModuleBuilder m => MonadModuleBuilder (LazyState.StateT s m)+instance (MonadModuleBuilder m, Monoid w) => MonadModuleBuilder (StrictRWS.RWST r w s m)+instance (MonadModuleBuilder m, Monoid w) => MonadModuleBuilder (LazyRWS.RWST r w s m)+instance MonadModuleBuilder m => MonadModuleBuilder (ReaderT r m)+instance (MonadModuleBuilder m, Monoid w) => MonadModuleBuilder (WriterT w m)+instance MonadModuleBuilder m => MonadModuleBuilder (ExceptT e m)++runModuleBuilderT :: Monad m => ModuleBuilderT m a -> m Module+runModuleBuilderT (ModuleBuilderT m) =+ Module . DList.toList . definitions <$> execStateT m beginState+ where+ beginState = ModuleBuilderState mempty mempty []+{-# INLINEABLE runModuleBuilderT #-}++withFunctionAttributes+ :: MonadModuleBuilder m+ => ([FunctionAttribute] -> [FunctionAttribute])+ -> m a -> m a+withFunctionAttributes f m = do+ fnAttrs <- liftModuleBuilderState (gets defaultFunctionAttributes)+ liftModuleBuilderState $+ modify $ \s -> s { defaultFunctionAttributes = f fnAttrs }+ result <- m+ liftModuleBuilderState $+ modify $ \s -> s { defaultFunctionAttributes = fnAttrs }+ pure result+{-# INLINEABLE withFunctionAttributes #-}++resetFunctionAttributes :: MonadModuleBuilder m => m ()+resetFunctionAttributes =+ liftModuleBuilderState $+ modify $ \s -> s { defaultFunctionAttributes = mempty }+{-# INLINEABLE resetFunctionAttributes #-}++getDefaultFunctionAttributes :: MonadModuleBuilder m => m [FunctionAttribute]+getDefaultFunctionAttributes =+ liftModuleBuilderState $ gets defaultFunctionAttributes+{-# INLINEABLE getDefaultFunctionAttributes #-}++runModuleBuilder :: ModuleBuilder a -> Module+runModuleBuilder = runIdentity . runModuleBuilderT+{-# INLINEABLE runModuleBuilder #-}++function :: (HasCallStack, MonadModuleBuilder m)+ => Name -> [(Type, ParameterName)] -> Type -> ([Operand] -> IRBuilderT m a) -> m Operand+function name args retTy fnBody = do+ fnAttrs <- getDefaultFunctionAttributes++ (names, instrs) <- runIRBuilderT $ do+ (names, operands) <- unzip <$> traverse (uncurry mkOperand) args+ resetFunctionAttributes -- This is done to avoid functions emitted in the body that not automatically copy the same attributes+ _ <- fnBody operands+ pure names++ liftModuleBuilderState $+ modify $ \s -> s { defaultFunctionAttributes = fnAttrs }+ let args' = zipWith (\argName (ty, _) -> (ty, ParameterName $ unName argName)) names args+ emitDefinition $ GlobalDefinition $ Function name retTy args' fnAttrs instrs+ pure $ ConstantOperand $ GlobalRef (ptr (FunctionType retTy $ map fst args)) name+{-# INLINEABLE function #-}++emitDefinition :: MonadModuleBuilder m => Definition -> m ()+emitDefinition def =+ liftModuleBuilderState $ modify $ \s -> s { definitions = DList.snoc (definitions s) def }+{-# INLINEABLE emitDefinition #-}++getTypedefs :: MonadModuleBuilder m => m (Map Name Type)+getTypedefs =+ liftModuleBuilderState $ gets types+{-# INLINEABLE getTypedefs #-}++lookupType :: MonadModuleBuilder m => Name -> m (Maybe Type)+lookupType name =+ liftModuleBuilderState $ gets (Map.lookup name . types)+{-# INLINEABLE lookupType #-}++addType :: MonadModuleBuilder m => Name -> Type -> m ()+addType name ty =+ liftModuleBuilderState $ modify $ \s -> s { types = Map.insert name ty (types s) }+{-# INLINEABLE addType #-}++global :: MonadModuleBuilder m => Name -> Type -> Constant -> m Operand+global name ty constant = do+ emitDefinition $ GlobalDefinition $ GlobalVariable name ty constant+ pure $ ConstantOperand $ GlobalRef (ptr ty) name+{-# INLINEABLE global #-}++globalUtf8StringPtr :: (HasCallStack, MonadModuleBuilder m, MonadIRBuilder m)+ => T.Text -> Name -> m Operand+globalUtf8StringPtr txt name = do+ let utf8Bytes = BS.snoc (TE.encodeUtf8 txt) 0 -- 0-terminated UTF8 string+ llvmValues = map (Int 8 . toInteger) $ BS.unpack utf8Bytes+ arrayValue = Array i8 llvmValues+ constant = ConstantOperand arrayValue+ ty = typeOf constant+ -- This definition will end up before the function this is used in+ addr <- global name ty arrayValue+ let instr = GetElementPtr On addr [ ConstantOperand $ Int 32 0+ , ConstantOperand $ Int 32 0+ ]+ emitInstr (ptr i8) instr+{-# INLINEABLE globalUtf8StringPtr #-}++-- NOTE: typedefs are only allowed for structs, even though clang also allows it+-- for primitive types. This is done to avoid weird inconsistencies with the LLVM JIT+-- (where this is not allowed).+typedef :: MonadModuleBuilder m => Name -> Flag Packed -> [Type] -> m Type+typedef name packed tys = do+ let ty = StructureType packed tys+ emitDefinition $ TypeDefinition name (Clear ty)+ addType name ty+ pure $ NamedTypeReference name+{-# INLINEABLE typedef #-}++opaqueTypedef :: MonadModuleBuilder m => Name -> m Type+opaqueTypedef name = do+ emitDefinition $ TypeDefinition name Opaque+ pure $ NamedTypeReference name+{-# INLINEABLE opaqueTypedef #-}++extern :: MonadModuleBuilder m => Name -> [Type] -> Type -> m Operand+extern name argTys retTy = do+ let args = [(argTy, ParameterName "") | argTy <- argTys]+ fnAttrs <- getDefaultFunctionAttributes+ emitDefinition $ GlobalDefinition $ Function name retTy args fnAttrs []+ let fnTy = ptr $ FunctionType retTy argTys+ pure $ ConstantOperand $ GlobalRef fnTy name+{-# INLINEABLE extern #-}++-- NOTE: Only used internally, this creates an unassigned operand+mkOperand :: Monad m => Type -> ParameterName -> IRBuilderT m (Name, Operand)+mkOperand ty paramName = do+ name <- case paramName of+ NoParameterName -> freshName Nothing+ ParameterName name -> freshName (Just name)+ pure (name, LocalRef ty name)+{-# INLINEABLE mkOperand #-}++renderModule :: Renderer Module+renderModule buf (Module defs) =+ sepBy "\n\n"# buf defs renderDefinition+{-# INLINEABLE renderModule #-}++renderDefinition :: Renderer Definition+renderDefinition buf = \case+ GlobalDefinition g ->+ renderGlobal buf g+ TypeDefinition name typeDef ->+ case typeDef of+ Opaque ->+ (buf |>. '%') `renderName` name |># " = type opaque"#+ Clear ty ->+ ((buf |>. '%') `renderName` name |># " = type "#) `renderType` ty+{-# INLINEABLE renderDefinition #-}++renderGlobal :: Renderer Global+renderGlobal buf = \case+ GlobalVariable name ty constant ->+ (((((buf |>. '@') `renderName` name) |># " = global "#) `renderType` ty) |>. ' ') `renderConstant` constant+ Function name retTy args attrs body+ | null body ->+ hsep (tupled ((((buf |># "declare external ccc "#) `renderType` retTy) |># " @"#) `renderName` name) argTys renderType+ |># (if null attrs then ""# else " "#)) attrs renderFunctionAttr+ | otherwise ->+ vsep (hsep (tupled ((((buf |># "define external ccc "#) `renderType` retTy) |># " @"#) `renderName` name) (zip [0..] args) renderArg |>. ' ') attrs renderFunctionAttr+ |># (if null attrs then "{\n"# else " {\n"#)) body renderBasicBlock |># "\n}"#+ where+ argTys = map fst args+ renderArg :: Renderer (Int, (Type, ParameterName))+ renderArg buf' (i, (argTy, nm)) =+ let localRef = case nm of+ NoParameterName ->+ LocalRef argTy $ Name $ T.pack $ show i+ ParameterName paramName ->+ LocalRef argTy $ Name paramName+ in ((buf' `renderType` argTy) |>. ' ') `renderOperand` localRef+{-# INLINEABLE renderGlobal #-}++renderFunctionAttr :: Renderer FunctionAttribute+renderFunctionAttr buf = \case+ AlwaysInline ->+ buf |># "alwaysinline"#+ WasmExportName name ->+ dquotes+ (dquotes buf (|># "wasm-export-name"#) |>. '=')+ (|> name)+{-# INLINEABLE renderFunctionAttr #-}
+ lib/LLVM/Codegen/Name.hs view
@@ -0,0 +1,31 @@+module LLVM.Codegen.Name+ ( Name(..)+ , unName+ , renderName+ ) where++import Data.Text+import Data.String+import LLVM.Pretty++data Name+ = Generated !Int+ | Name !Text+ deriving (Eq, Ord, Show)++instance IsString Name where+ fromString = Name . fromString+ {-# INLINABLE fromString #-}++unName :: Name -> Text+unName = \case+ Name name -> name+ Generated x -> pack $! show x++renderName :: Renderer Name+renderName buf = \case+ Name name ->+ buf |> name+ Generated x ->+ buf |>$ x+{-# INLINABLE renderName #-}
+ lib/LLVM/Codegen/Operand.hs view
@@ -0,0 +1,70 @@+module LLVM.Codegen.Operand+ ( Operand(..)+ , Constant(..)+ , typeOf+ , renderOperand+ , renderConstant+ ) where++import LLVM.Codegen.Name+import LLVM.Codegen.Type+import LLVM.Pretty+import Data.Word+++data Constant+ = GlobalRef !Type !Name+ | Array !Type ![Constant]+ | Int !Word32 !Integer+ | NullPtr !Type+ | Undef !Type+ deriving (Eq, Ord, Show)++data Operand+ = LocalRef !Type !Name+ | ConstantOperand !Constant+ deriving (Eq, Ord, Show)++typeOf :: Operand -> Type+typeOf = \case+ LocalRef ty _ ->+ ty+ ConstantOperand c ->+ typeOfConstant c+ where+ typeOfConstant = \case+ GlobalRef ty _ ->+ ty+ Array ty cs ->+ ArrayType (fromIntegral $ length cs) ty+ Int bits _ ->+ IntType bits+ NullPtr ty ->+ ptr ty+ Undef ty ->+ ty+{-# INLINEABLE typeOf #-}++renderConstant :: Renderer Constant+renderConstant buf = \case+ GlobalRef _ name ->+ (buf |>. '@') `renderName` name+ Array ty cs ->+ brackets buf (\buf' -> commas buf' cs renderValue)+ where+ renderValue :: Renderer Constant+ renderValue buf' c = (renderType buf' ty |>. ' ') `renderConstant` c+ Int _bits x ->+ buf |>$ (fromInteger x :: Int)+ NullPtr _ ->+ buf |># "zeroinitializer"#+ Undef _ ->+ buf |># "undef"#++renderOperand :: Renderer Operand+renderOperand buf = \case+ LocalRef _ name ->+ (buf |>. '%') `renderName` name+ ConstantOperand c ->+ renderConstant buf c+{-# INLINEABLE renderOperand #-}
+ lib/LLVM/Codegen/Type.hs view
@@ -0,0 +1,63 @@+module LLVM.Codegen.Type+ ( Type(..)+ , Packed+ , i1+ , i8+ , i16+ , i32+ , i64+ , ptr+ , void+ , renderType+ ) where++import LLVM.Codegen.Name+import LLVM.Codegen.Flag+import Data.Word+import LLVM.Pretty++data Packed++data Type+ = IntType !Word32+ | FunctionType !Type ![Type]+ | PointerType !Type+ | VoidType+ | StructureType !(Flag Packed) ![Type]+ | ArrayType !Word32 !Type+ | NamedTypeReference !Name+ deriving (Eq, Ord, Show)++i1, i8, i16, i32, i64 :: Type+i1 = IntType 1+i8 = IntType 8+i16 = IntType 16+i32 = IntType 32+i64 = IntType 64++ptr :: Type -> Type+ptr = PointerType++void :: Type+void = VoidType++renderType :: Renderer Type+renderType buf = \case+ PointerType _ ->+ buf |># "ptr"#+ IntType bits ->+ buf |>. 'i' |>$ bits+ FunctionType retTy argTys ->+ tupled (renderType buf retTy |>. ' ') argTys renderType+ NamedTypeReference name ->+ (buf |>. '%') `renderName` name+ VoidType ->+ buf |># "void"#+ StructureType packed elemTys+ | packed == On ->+ commas (buf |># "<{"#) elemTys renderType |># "}>"#+ | otherwise ->+ braces buf (\buf' -> commas buf' elemTys renderType)+ ArrayType count ty ->+ brackets buf (\buf' -> (buf' |>$ count |># " x "#) `renderType` ty)+{-# INLINABLE renderType #-}
+ lib/LLVM/Pretty.hs view
@@ -0,0 +1,112 @@+module LLVM.Pretty+ ( Renderer+ , renderDoc+ , (|>)+ , (|>.)+ , (|>#)+ , (|>$)+ , Buffer+ , Addr#+ , runBuffer+ , consumeBuffer+ , hsep+ , vsep+ , sepBy+ , brackets+ , braces+ , parens+ , commas+ , dquotes+ , tupled+ , withIndent+ , optional+ , renderMaybe+ ) where++import Prelude hiding (EQ)+import Data.Text.Builder.Linear.Buffer+import Data.Text (Text)+import qualified Data.List as L+import GHC.Prim (Addr#)+import LLVM.Codegen.Flag++type Renderer a = Buffer %1 -> a -> Buffer++renderDoc :: Renderer a -> a -> Text+renderDoc f d =+ runBuffer (`f` d)+{-# INLINABLE renderDoc #-}++-- TODO better name+type BufferDecorator = Buffer %1 -> (Buffer %1 -> Buffer) -> Buffer++brackets :: BufferDecorator+brackets = betweenChars '[' ']'+{-# INLINABLE brackets #-}++braces :: BufferDecorator+braces = betweenChars '{' '}'+{-# INLINABLE braces #-}++parens :: BufferDecorator+parens = betweenChars '(' ')'+{-# INLINABLE parens #-}++dquotes :: BufferDecorator+dquotes = betweenChars '"' '"'+{-# INLINABLE dquotes #-}++betweenChars :: Char -> Char -> BufferDecorator+betweenChars begin end buf f =+ f (buf |>. begin) |>. end+{-# INLINABLE betweenChars #-}++withIndent :: BufferDecorator+withIndent buf' f =+ f (buf' |># " "#)+{-# INLINABLE withIndent #-}++hsep :: Buffer %1 -> [a] -> Renderer a -> Buffer+hsep = sepBy " "#+{-# INLINABLE hsep #-}++vsep :: Buffer %1 -> [a] -> Renderer a -> Buffer+vsep = sepBy "\n"#+{-# INLINABLE vsep #-}++tupled :: Buffer %1 -> [a] -> Renderer a -> Buffer+tupled buf as f =+ parens buf (\buf' -> commas buf' as f)+{-# INLINABLE tupled #-}++commas :: Buffer %1 -> [a] -> Renderer a -> Buffer+commas = sepBy ", "#+{-# INLINABLE commas #-}++sepBy :: forall a. Addr# -> Buffer %1 -> [a] -> Renderer a -> Buffer+sepBy separator buf as f =+ foldlIntoBuffer combine buf parts+ where+ parts = L.intersperse Nothing $ map Just as+ combine :: Renderer (Maybe a)+ combine buf' = \case+ Nothing ->+ buf' |># separator+ Just a ->+ f buf' a+{-# INLINABLE sepBy #-}++optional :: Flag a -> BufferDecorator+optional flag buf f = case flag of+ Off -> buf+ On -> f buf+{-# INLINABLE optional #-}++renderMaybe :: Buffer %1 -> Maybe a -> Renderer a -> Buffer+renderMaybe buf mValue render =+ case mValue of+ Nothing ->+ buf+ Just value ->+ render buf value+{-# INLINABLE renderMaybe #-}
+ llvm-codegen.cabal view
@@ -0,0 +1,130 @@+cabal-version: 2.0++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name: llvm-codegen+version: 0.1.0.0+category: Compilers+homepage: https://github.com/luc-tielen/llvm-codegen+author: Luc Tielen+maintainer: luc.tielen@gmail.com+copyright: Luc Tielen, 2024+license: BSD3+license-file: LICENSE+build-type: Custom+extra-source-files: README.md+synopsis: A DSL for LLVM IR code generation based on llvm-hs.+description:+ A DSL for LLVM IR code generation. Heavily inspired by llvm-hs.++custom-setup+ setup-depends:+ base <5+ , Cabal <4+ , containers++library+ -- cabal-fmt: expand lib+ exposed-modules:+ LLVM.C.API+ LLVM.C.Bindings+ LLVM.Codegen+ LLVM.Codegen.Flag+ LLVM.Codegen.IR+ LLVM.Codegen.IRBuilder+ LLVM.Codegen.IRBuilder.Monad+ LLVM.Codegen.ModuleBuilder+ LLVM.Codegen.Name+ LLVM.Codegen.Operand+ LLVM.Codegen.Type+ LLVM.Pretty++ other-modules: Paths_llvm_codegen+ autogen-modules: Paths_llvm_codegen+ hs-source-dirs: lib+ default-extensions:+ DefaultSignatures+ DeriveAnyClass+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ DerivingStrategies+ DerivingVia+ FlexibleContexts+ FlexibleInstances+ LambdaCase+ LinearTypes+ MagicHash+ OverloadedStrings+ ScopedTypeVariables+ TupleSections++ ghc-options:+ -Wall -fhide-source-paths -fno-show-valid-hole-fits+ -fno-sort-valid-hole-fits -optl=-lLLVM++ build-depends:+ base >=4.7 && <5+ , bytestring >=0.11 && <0.12+ , containers <1+ , dlist >=1 && <2+ , ghc-prim <1+ , mmorph >=1 && <2+ , mtl >=2 && <3+ , text >=2 && <3+ , text-builder-linear <1++ default-language: Haskell2010++test-suite llvm-codegen-test+ type: exitcode-stdio-1.0+ main-is: test.hs+ other-modules:+ Paths_llvm_codegen+ Test.LLVM.C.APISpec+ Test.LLVM.Codegen.IRBuilderSpec+ Test.LLVM.Codegen.IRCombinatorsSpec++ autogen-modules: Paths_llvm_codegen+ hs-source-dirs: tests+ default-extensions:+ DefaultSignatures+ DeriveAnyClass+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ DerivingStrategies+ DerivingVia+ FlexibleContexts+ FlexibleInstances+ LambdaCase+ LinearTypes+ MagicHash+ OverloadedStrings+ ScopedTypeVariables+ TupleSections++ ghc-options:+ -Wall -fhide-source-paths -fno-show-valid-hole-fits+ -fno-sort-valid-hole-fits -optl=-lLLVM++ build-depends:+ base >=4.7 && <5+ , bytestring >=0.11 && <0.12+ , containers <1+ , dlist >=1 && <2+ , ghc-prim <1+ , hspec >=2.6.1 && <3.0.0+ , hspec-hedgehog <1+ , llvm-codegen+ , mmorph >=1 && <2+ , mtl >=2 && <3+ , neat-interpolation <1+ , text >=2 && <3+ , text-builder-linear <1++ default-language: Haskell2010
+ tests/Test/LLVM/C/APISpec.hs view
@@ -0,0 +1,118 @@+module Test.LLVM.C.APISpec+ ( module Test.LLVM.C.APISpec+ ) where++import Test.Hspec+import Foreign hiding (void)+import qualified LLVM.C.API as C+import LLVM.Codegen.Type+import LLVM.Codegen.Name+import LLVM.Codegen.Flag++-- NOTE: if it can't find libffi, you're linking against wrong libLLVM!+-- Be sure to update Setup.hs LLVM version as well to be in sync!++mkType :: ForeignPtr C.Context -> Type -> IO (Ptr C.Type)+mkType ctx = \case+ VoidType ->+ C.mkVoidType ctx+ IntType bits ->+ C.mkIntType ctx bits+ PointerType ty ->+ C.mkPointerType =<< mkType ctx ty+ StructureType packed tys -> do+ tys' <- traverse (mkType ctx) tys+ C.mkAnonStructType ctx tys' packed+ ArrayType count ty -> do+ ty' <- mkType ctx ty+ C.mkArrayType ty' count+ FunctionType retTy argTys -> do+ retTy' <- mkType ctx retTy+ argTys' <- traverse (mkType ctx) argTys+ C.mkFunctionType retTy' argTys'+ NamedTypeReference name ->+ C.getTypeByName ctx name+++-- TODO: do more than checking against nullptr in first tests++spec :: Spec+spec = describe "LLVM C API" $ parallel $ do+ it "can create a LLVM context" $ do+ ctx <- C.mkContext+ withForeignPtr ctx $ \c ->+ c `shouldNotBe` nullPtr++ it "can create an empty LLVM module" $ do+ ctx <- C.mkContext+ llvmMod <- C.mkModule ctx "test"+ withForeignPtr llvmMod $ \llvmModule ->+ llvmModule `shouldNotBe` nullPtr++ it "can set the target data for a LLVM module" $ do+ ctx <- C.mkContext+ newTd <- C.mkTargetData "e-m:e-p:32:32-p10:8:8-p20:8:8-i64:64-n32:64-S128-ni:1:10:20" -- WASM layout+ llvmMod <- C.mkModule ctx "test"+ C.setTargetData llvmMod newTd+ td <- C.getTargetData llvmMod+ td `shouldNotBe` nullPtr++ it "can extract the target data from a LLVM module" $ do+ ctx <- C.mkContext+ llvmMod <- C.mkModule ctx "test"+ td <- C.getTargetData llvmMod+ td `shouldNotBe` nullPtr++ let assertTypeSizes :: ((Type -> Word64 -> IO ()) -> IO ()) -> IO ()+ assertTypeSizes f = do+ ctx <- C.mkContext+ llvmMod <- C.mkModule ctx "test"+ td <- C.getTargetData llvmMod+ f $ \ty expectedSize -> do+ ty' <- mkType ctx ty+ actualSize <- C.sizeOfType td ty'+ actualSize `shouldBe` expectedSize++ it "can compute the size of an integer type" $ do+ assertTypeSizes $ \assert -> do+ assert i1 1+ assert i8 1+ assert i16 2+ assert i32 4+ assert i64 8++ -- NOTE: not allowed for "void" => has no size, causes SIGILL (due to missing return in a function in libLLVM / assert triggered)++ it "can compute the size of a pointer type" $ do+ assertTypeSizes $ \assert -> do+ assert (ptr i1) 8+ assert (ptr i32) 8+ assert (ptr i64) 8++ it "can compute the size of a struct type" $ do+ assertTypeSizes $ \assert -> do+ assert (StructureType Off [i8]) 1+ assert (StructureType Off [i8, i8]) 2+ assert (StructureType Off [i8, i16]) 4 -- padding!+ assert (StructureType On [i8, i16]) 3+ assert (StructureType On [i8, StructureType Off [i8]]) 2+ assert (StructureType Off [ArrayType 5 i32, i1]) 24 -- padding!+ assert (StructureType On [ArrayType 5 i32, i1]) 21+ assert (StructureType On [i32, i64]) 12 -- no padding, 4-byte alignment for i64?++ it "can compute the size of an array type" $ do+ assertTypeSizes $ \assert -> do+ assert (ArrayType 1 i1) 1+ assert (ArrayType 10 i1) 10+ assert (ArrayType 10 i32) 40+ assert (ArrayType 5 (StructureType Off [i32, i64])) (5 * 12)++ -- NOTE: not allowed for function type => has no size, triggers undefined behavior.++ it "returns null for an unknown named type reference" $ do+ let ty = NamedTypeReference $ Name "unknown"+ ctx <- C.mkContext+ ty' <- mkType ctx ty+ ty' `shouldBe` nullPtr++ -- TODO test for known named type ref, but need to first add to module
+ tests/Test/LLVM/Codegen/IRBuilderSpec.hs view
@@ -0,0 +1,881 @@+{-# LANGUAGE QuasiQuotes, RecursiveDo #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Test.LLVM.Codegen.IRBuilderSpec+ ( module Test.LLVM.Codegen.IRBuilderSpec+ ) where++import Prelude hiding (and, or, EQ)+import qualified Data.Text as T+import Data.Foldable hiding (and, or)+import Test.Hspec+import NeatInterpolation+import Data.Text (Text)+import LLVM.Codegen+++checkIR :: ModuleBuilder a -> Text -> IO ()+checkIR llvmModule expectedOutput = do+ let ir = ppllvm $ runModuleBuilder llvmModule+ ir `shouldBe` expectedOutput++spec :: Spec+spec = describe "constructing LLVM IR" $ do+ -- Module level++ it "supports an empty module" $ do+ let ir = pure ()+ checkIR ir ""++ it "supports global constants" $ do+ let ir = global "my_constant" i32 (Int 32 42)+ checkIR ir [text|+ @my_constant = global i32 42+ |]+ let ir2 = do+ _ <- global "my_constant" i32 (Int 32 42)+ global "my_constant2" i64 (Int 64 1000)+ checkIR ir2 [text|+ @my_constant = global i32 42++ @my_constant2 = global i64 1000+ |]++ it "supports creating and using global utf8 string constants" $ do+ let ir = do+ function "utf8_string_usage" [] i8 $ \[] -> do+ str <- globalUtf8StringPtr "string_contents" "my_string"+ char <- load str 0+ ret char+ checkIR ir [text|+ @my_string = global [16 x i8] [i8 115, i8 116, i8 114, i8 105, i8 110, i8 103, i8 95, i8 99, i8 111, i8 110, i8 116, i8 101, i8 110, i8 116, i8 115, i8 0]++ define external ccc i8 @utf8_string_usage() {+ start:+ %0 = getelementptr inbounds [16 x i8], ptr @my_string, i32 0, i32 0+ %1 = load i8, ptr %0+ ret i8 %1+ }+ |]++ it "supports type definitions" $ do+ let ir = mdo+ let myType = ArrayType 10 i16+ _ <- typedef "my_type2" Off [myType, myType]+ _ <- typedef "my_type2_packed" On [myType, myType]+ _ <- typedef "struct_with_ptrs" Off [ptr i8, ptr i16]+ s <- typedef "recursive" Off [ptr s]+ _ <- opaqueTypedef "my_opaque_type"+ pure ()+ checkIR ir [text|+ %my_type2 = type {[10 x i16], [10 x i16]}++ %my_type2_packed = type <{[10 x i16], [10 x i16]}>++ %struct_with_ptrs = type {ptr, ptr}++ %recursive = type {ptr}++ %my_opaque_type = type opaque+ |]++ it "supports external definitions" $ do+ let ir = do+ _ <- extern "symbol1" [i32, i64] (ptr i8)+ extern "symbol2" [] (ptr i8)+ checkIR ir [text|+ declare external ccc ptr @symbol1(i32, i64)++ declare external ccc ptr @symbol2()+ |]++ it "supports functions" $ do+ let ir = do+ function "do_add" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> do+ c <- add a b+ ret c+ checkIR ir [text|+ define external ccc i32 @do_add(i32 %a_0, i32 %b_0) {+ start:+ %0 = add i32 %a_0, %b_0+ ret i32 %0+ }+ |]+ let ir2 = do+ function "func_with_ptrs" [(ptr i32, "a"), (ptr i8, "b")] (ptr i32) $ \[a, _b] -> do+ ret a+ checkIR ir2 [text|+ define external ccc ptr @func_with_ptrs(ptr %a_0, ptr %b_0) {+ start:+ ret ptr %a_0+ }+ |]++ it "renders functions in order they are defined" $ do+ let ir = do+ _ <- function "do_add" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> do+ c <- add a b+ ret c+ function "do_add2" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> do+ c <- add a b+ ret c+ checkIR ir [text|+ define external ccc i32 @do_add(i32 %a_0, i32 %b_0) {+ start:+ %0 = add i32 %a_0, %b_0+ ret i32 %0+ }++ define external ccc i32 @do_add2(i32 %a_0, i32 %b_0) {+ start:+ %0 = add i32 %a_0, %b_0+ ret i32 %0+ }+ |]++ -- IR level++ it "supports defining basic blocks" $ do+ let ir = do+ function "do_add" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> do+ _ <- block+ c <- add a b+ ret c+ checkIR ir [text|+ define external ccc i32 @do_add(i32 %a_0, i32 %b_0) {+ start:+ br label %block_0+ block_0:+ %0 = add i32 %a_0, %b_0+ ret i32 %0+ }+ |]++ it "supports giving a basic block a user-defined name" $ do+ let ir = do+ function "do_add" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> do+ c <- add a b+ ret c+ checkIR ir [text|+ define external ccc i32 @do_add(i32 %a_0, i32 %b_0) {+ start:+ %0 = add i32 %a_0, %b_0+ ret i32 %0+ }+ |]++ it "supports giving function parameters a user-defined name" $ do+ let ir = do+ function "do_add" [(i32, "arg0"), (i32, "arg1")] i32 $ \[a, b] -> do+ c <- add a b+ ret c+ checkIR ir [text|+ define external ccc i32 @do_add(i32 %arg0_0, i32 %arg1_0) {+ start:+ %0 = add i32 %arg0_0, %arg1_0+ ret i32 %0+ }+ |]++ it "supports automatic naming of function parameters" $ do+ let ir = do+ function "do_add" [(i32, NoParameterName), (i32, NoParameterName)] i32 $ \[a, b] -> do+ c <- add a b+ ret c+ checkIR ir [text|+ define external ccc i32 @do_add(i32 %0, i32 %1) {+ start:+ %2 = add i32 %0, %1+ ret i32 %2+ }+ |]++ it "automatically terminates previous basic block when starting new block" $ do+ let ir = do+ function "do_add" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> mdo+ c <- add a b+ -- NOTE: invalid IR+ _ <- blockNamed "next"+ ret c+ checkIR ir [text|+ define external ccc i32 @do_add(i32 %a_0, i32 %b_0) {+ start:+ %0 = add i32 %a_0, %b_0+ ret void+ next_0:+ ret i32 %0+ }+ |]++ it "avoids name collisions by appending a unique suffix" $ do+ let ir = do+ function "do_add" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> mdo+ _ <- blockNamed "blk"+ c <- add a b+ _ <- add c c+ br blk2+ blk2 <- blockNamed "blk"+ ret c+ checkIR ir [text|+ define external ccc i32 @do_add(i32 %a_0, i32 %b_0) {+ start:+ br label %blk_0+ blk_0:+ %0 = add i32 %a_0, %b_0+ %1 = add i32 %0, %0+ br label %blk_1+ blk_1:+ ret i32 %0+ }+ |]++ it "shifts allocas to start of the entry basic block" $ do+ let ir = do+ function "func" [(i32, "a")] i32 $ \[a] -> mdo+ _ <- alloca i32 Nothing 0+ b <- add a a+ br blk+ blk <- blockNamed "blk"+ _ <- alloca i64 Nothing 0+ c <- add b b+ ret c+ checkIR ir [text|+ define external ccc i32 @func(i32 %a_0) {+ start:+ %stack.ptr_0 = alloca i32+ %stack.ptr_1 = alloca i64+ %0 = add i32 %a_0, %a_0+ br label %blk_0+ blk_0:+ %1 = add i32 %0, %0+ ret i32 %1+ }+ |]++ it "supports 'add' instruction" $ do+ let ir = do+ function "do_add" [(i8, "a"), (i8, "b")] i8 $ \[a, b] -> do+ c <- add a b+ ret c+ checkIR ir [text|+ define external ccc i8 @do_add(i8 %a_0, i8 %b_0) {+ start:+ %0 = add i8 %a_0, %b_0+ ret i8 %0+ }+ |]++ it "supports 'mul' instruction" $ do+ let ir = do+ function "func" [(i8, "a"), (i8, "b")] i8 $ \[a, b] -> do+ c <- mul a b+ ret c+ checkIR ir [text|+ define external ccc i8 @func(i8 %a_0, i8 %b_0) {+ start:+ %0 = mul i8 %a_0, %b_0+ ret i8 %0+ }+ |]++ it "supports 'sub' instruction" $ do+ let ir = do+ function "func" [(i8, "a"), (i8, "b")] i8 $ \[a, b] -> do+ c <- sub a b+ ret c+ checkIR ir [text|+ define external ccc i8 @func(i8 %a_0, i8 %b_0) {+ start:+ %0 = sub i8 %a_0, %b_0+ ret i8 %0+ }+ |]++ it "supports 'udiv' instruction" $ do+ let ir = do+ function "func" [(i8, "a"), (i8, "b")] i8 $ \[a, b] -> do+ c <- udiv a b+ ret c+ checkIR ir [text|+ define external ccc i8 @func(i8 %a_0, i8 %b_0) {+ start:+ %0 = udiv i8 %a_0, %b_0+ ret i8 %0+ }+ |]++ it "supports 'and' instruction" $ do+ let ir = do+ function "func" [(i1, "a"), (i1, "b")] i1 $ \[a, b] -> do+ c <- and a b+ ret c+ checkIR ir [text|+ define external ccc i1 @func(i1 %a_0, i1 %b_0) {+ start:+ %0 = and i1 %a_0, %b_0+ ret i1 %0+ }+ |]++ it "supports 'or' instruction" $ do+ let ir = do+ function "func" [(i1, "a"), (i1, "b")] i1 $ \[a, b] -> do+ c <- or a b+ ret c+ checkIR ir [text|+ define external ccc i1 @func(i1 %a_0, i1 %b_0) {+ start:+ %0 = or i1 %a_0, %b_0+ ret i1 %0+ }+ |]++ it "supports 'trunc' instruction" $ do+ let ir = do+ function "func" [(i64, "a")] i32 $ \[a] -> do+ b <- trunc a i32+ ret b+ checkIR ir [text|+ define external ccc i32 @func(i64 %a_0) {+ start:+ %0 = trunc i64 %a_0 to i32+ ret i32 %0+ }+ |]++ it "supports 'zext' instruction" $ do+ let ir = do+ function "func" [(i32, "a")] i64 $ \[a] -> do+ b <- zext a i64+ ret b+ checkIR ir [text|+ define external ccc i64 @func(i32 %a_0) {+ start:+ %0 = zext i32 %a_0 to i64+ ret i64 %0+ }+ |]++ it "supports 'ptrtoint' instruction" $ do+ let ir = do+ function "func" [(ptr i32, "ptr_a")] i64 $ \[a] -> do+ b <- ptrtoint a i64+ ret b+ checkIR ir [text|+ define external ccc i64 @func(ptr %ptr_a_0) {+ start:+ %0 = ptrtoint ptr %ptr_a_0 to i64+ ret i64 %0+ }+ |]++ it "supports 'bitcast' instruction" $ do+ -- TODO improve example once vector or float types are added+ let ir = do+ function "func" [(ptr i32, "ptr_a")] (ptr i64) $ \[a] -> do+ b <- a `bitcast` ptr i64+ ret b+ checkIR ir [text|+ define external ccc ptr @func(ptr %ptr_a_0) {+ start:+ %0 = bitcast ptr %ptr_a_0 to ptr+ ret ptr %0+ }+ |]++ it "supports 'icmp' instruction" $ do+ let scenarios =+ [ (EQ, "eq")+ , (NE, "ne")+ , (ULE, "ule")+ , (UGT, "ugt")+ , (UGE, "uge")+ , (UGT, "ugt")+ , (SLE, "sle")+ , (SLT, "slt")+ , (SGE, "sge")+ , (SGT, "sgt")+ ]+ for_ scenarios $ \(cmp, cmpText) -> do+ let ir = do+ function "func" [(i32, "a"), (i32, "b")] i1 $ \[a, b] -> do+ c <- icmp cmp a b+ ret c+ ir2 = do+ function "func2" [(ptr i32, "a"), (ptr i32, "b")] i1 $ \[a, b] -> do+ c <- icmp cmp a b+ ret c+ checkIR ir [text|+ define external ccc i1 @func(i32 %a_0, i32 %b_0) {+ start:+ %0 = icmp $cmpText i32 %a_0, %b_0+ ret i1 %0+ }+ |]+ checkIR ir2 [text|+ define external ccc i1 @func2(ptr %a_0, ptr %b_0) {+ start:+ %0 = icmp $cmpText ptr %a_0, %b_0+ ret i1 %0+ }+ |]++ it "supports 'alloca' instruction" $ do+ let ir = do+ function "func" [(i32, "a")] i32 $ \[a] -> do+ _ <- alloca i64 Nothing 0+ _ <- alloca i1 (Just $ int32 8) 0+ _ <- alloca i1 Nothing 8+ ret a+ checkIR ir [text|+ define external ccc i32 @func(i32 %a_0) {+ start:+ %stack.ptr_0 = alloca i64+ %stack.ptr_1 = alloca i1, i32 8+ %stack.ptr_2 = alloca i1, align 8+ ret i32 %a_0+ }+ |]++ it "supports 'gep' instruction on pointers" $ do+ let ir = do+ function "func" [(ptr i64, "a"), (ptr (ptr (ptr i64)), "b")] (ptr i64) $ \[a, b] -> do+ c <- gep a [int32 1]+ _ <- gep b [int32 2]+ ret c+ checkIR ir [text|+ define external ccc ptr @func(ptr %a_0, ptr %b_0) {+ start:+ %0 = getelementptr i64, ptr %a_0, i32 1+ %1 = getelementptr ptr, ptr %b_0, i32 2+ ret ptr %0+ }+ |]++ it "supports 'gep' instruction on structs" $ do+ let ir = do+ struct1 <- typedef "my_struct" Off [i32, i64]+ struct2 <- typedef "my_struct2" Off [struct1, i1]++ function "func" [(ptr struct2, "a")] (ptr i64) $ \[a] -> do+ c <- gep a [int32 0, int32 0, int32 1]+ _ <- gep a [int32 0, int32 1]+ ret c+ checkIR ir [text|+ %my_struct = type {i32, i64}++ %my_struct2 = type {%my_struct, i1}++ define external ccc ptr @func(ptr %a_0) {+ start:+ %0 = getelementptr %my_struct2, ptr %a_0, i32 0, i32 0, i32 1+ %1 = getelementptr %my_struct2, ptr %a_0, i32 0, i32 1+ ret ptr %0+ }+ |]++ it "supports 'gep' instruction on arrays" $ do+ let ir = do+ let array = ArrayType 10 i32++ function "func" [(ptr array, "a")] (ptr i32) $ \[a] -> do+ c <- gep a [int32 0, int32 5]+ ret c+ checkIR ir [text|+ define external ccc ptr @func(ptr %a_0) {+ start:+ %0 = getelementptr [10 x i32], ptr %a_0, i32 0, i32 5+ ret ptr %0+ }+ |]++ it "supports 'load' instruction" $ do+ let ir = do+ function "func" [(ptr i64, "a")] i64 $ \[a] -> do+ b <- load a 0+ _ <- load a 8+ ret b+ checkIR ir [text|+ define external ccc i64 @func(ptr %a_0) {+ start:+ %0 = load i64, ptr %a_0+ %1 = load i64, ptr %a_0, align 8+ ret i64 %0+ }+ |]++ it "supports 'store' instruction" $ do+ let ir = do+ function "func" [(ptr i64, "a")] void $ \[a] -> do+ store a 0 (int64 10)+ store a 8 (int64 10)+ retVoid+ checkIR ir [text|+ define external ccc void @func(ptr %a_0) {+ start:+ store i64 10, ptr %a_0+ store i64 10, ptr %a_0, align 8+ ret void+ }+ |]++ it "supports 'phi' instruction" $ do+ let ir = do+ function "func" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> mdo+ c <- icmp EQ a b+ condBr c block1 block2++ block1 <- block+ br block3++ block2 <- block+ br block3++ block3 <- block+ d <- phi [(a, block1), (b, block2)]+ ret d+ checkIR ir [text|+ define external ccc i32 @func(i32 %a_0, i32 %b_0) {+ start:+ %0 = icmp eq i32 %a_0, %b_0+ br i1 %0, label %block_0, label %block_1+ block_0:+ br label %block_2+ block_1:+ br label %block_2+ block_2:+ %1 = phi i32 [%a_0, %block_0], [%b_0, %block_1]+ ret i32 %1+ }+ |]+ let ir2 = do+ function "func" [(ptr i32, "a"), (ptr i32, "b")] (ptr i32) $ \[a, b] -> mdo+ c <- icmp EQ a b+ condBr c block1 block2++ block1 <- block+ br block3++ block2 <- block+ br block3++ block3 <- block+ d <- phi [(a, block1), (b, block2)]+ ret d+ checkIR ir2 [text|+ define external ccc ptr @func(ptr %a_0, ptr %b_0) {+ start:+ %0 = icmp eq ptr %a_0, %b_0+ br i1 %0, label %block_0, label %block_1+ block_0:+ br label %block_2+ block_1:+ br label %block_2+ block_2:+ %1 = phi ptr [%a_0, %block_0], [%b_0, %block_1]+ ret ptr %1+ }+ |]+++ it "supports 'call' instruction" $ do+ let ir = mdo+ func <- function "func" [(i32, "a")] i32 $ \[a] -> do+ ret =<< call func [a]++ func2 <- function "func2" [(ptr i32, "a")] i32 $ \[a] -> do+ ret =<< call func2 [a]++ pure ()+ checkIR ir [text|+ define external ccc i32 @func(i32 %a_0) {+ start:+ %0 = call ccc i32 @func(i32 %a_0)+ ret i32 %0+ }++ define external ccc i32 @func2(ptr %a_0) {+ start:+ %0 = call ccc i32 @func2(ptr %a_0)+ ret i32 %0+ }+ |]++ it "supports 'ret' instruction" $ do+ let ir = do+ function "func" [(i1, "a")] i1 $ \[a] -> do+ ret a+ checkIR ir [text|+ define external ccc i1 @func(i1 %a_0) {+ start:+ ret i1 %a_0+ }+ |]+ let ir2 = do+ function "func" [(ptr i1, "a")] (ptr i1) $ \[a] -> do+ ret a+ checkIR ir2 [text|+ define external ccc ptr @func(ptr %a_0) {+ start:+ ret ptr %a_0+ }+ |]+++ it "supports 'retVoid' instruction" $ do+ let ir = do+ function "func" [] void $ \[] -> do+ retVoid+ checkIR ir [text|+ define external ccc void @func() {+ start:+ ret void+ }+ |]++ it "only uses first terminator instruction" $ do+ let ir = do+ function "func" [] i1 $ \[] -> do+ ret (bit 0)+ ret (bit 1)+ checkIR ir [text|+ define external ccc i1 @func() {+ start:+ ret i1 0+ }+ |]++ it "doesn't emit a block if it has no instructions or terminator" $ do+ let ir = do+ function "func" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> mdo+ isZero <- eq a (int32 0)+ if' isZero $ do+ _ <- add a b+ ret $ int32 1000+ br blk++ blk <- block+ ret b+ checkIR ir [text|+ define external ccc i32 @func(i32 %a_0, i32 %b_0) {+ start:+ %0 = icmp eq i32 %a_0, 0+ br i1 %0, label %if_0, label %end_if_0+ if_0:+ %1 = add i32 %a_0, %b_0+ ret i32 1000+ end_if_0:+ br label %block_0+ block_0:+ ret i32 %b_0+ }+ |]++ it "supports 'br' instruction" $ do+ let ir = do+ function "func" [(i1, "a")] i1 $ \[a] -> mdo+ br block2++ block1 <- block+ ret a++ block2 <- block+ br block1+ checkIR ir [text|+ define external ccc i1 @func(i1 %a_0) {+ start:+ br label %block_1+ block_0:+ ret i1 %a_0+ block_1:+ br label %block_0+ }+ |]++ it "supports 'condBr' instruction" $ do+ let ir = do+ function "func" [(i1, "a")] i1 $ \[a] -> mdo+ condBr a block1 block2++ block1 <- block+ ret a++ block2 <- block+ condBr a block1 block3++ block3 <- block+ condBr a block1 block2+ checkIR ir [text|+ define external ccc i1 @func(i1 %a_0) {+ start:+ br i1 %a_0, label %block_0, label %block_1+ block_0:+ ret i1 %a_0+ block_1:+ br i1 %a_0, label %block_0, label %block_2+ block_2:+ br i1 %a_0, label %block_0, label %block_1+ }+ |]++ it "supports 'switch' instruction" $ do+ let ir = do+ function "func" [(i1, "a")] i1 $ \[a] -> mdo+ switch a defaultBlock [(bit 1, block1), (bit 0, block2)]+ block1 <- block+ ret a+ block2 <- block+ ret a+ defaultBlock <- block+ ret a+ checkIR ir [text|+ define external ccc i1 @func(i1 %a_0) {+ start:+ switch i1 %a_0, label %block_2 [i1 1, label %block_0 i1 0, label %block_1]+ block_0:+ ret i1 %a_0+ block_1:+ ret i1 %a_0+ block_2:+ ret i1 %a_0+ }+ |]+++ it "supports 'select' instruction" $ do+ let ir = do+ function "not" [(i1, "a")] i1 $ \[a] -> do+ b <- select a (bit 0) (bit 1)+ ret b+ checkIR ir [text|+ define external ccc i1 @not(i1 %a_0) {+ start:+ %0 = select i1 %a_0, i1 0, i1 1+ ret i1 %0+ }+ |]+ let ir2 = do+ function "with_ptrs" [(i1, "bool"), (ptr i8, "a"), (ptr i8, "b")] (ptr i8) $ \[boolean, a, b] -> do+ c <- select boolean a b+ ret c+ checkIR ir2 [text|+ define external ccc ptr @with_ptrs(i1 %bool_0, ptr %a_0, ptr %b_0) {+ start:+ %0 = select i1 %bool_0, ptr %a_0, ptr %b_0+ ret ptr %0+ }+ |]++ it "supports 'bit' for creating i1 values" $ do+ let ir = do+ function "func" [] i1 $ \[] -> do+ ret (bit 1)+ checkIR ir [text|+ define external ccc i1 @func() {+ start:+ ret i1 1+ }+ |]+ let ir2 = do+ function "func" [] i1 $ \[] -> do+ ret (bit 0)+ checkIR ir2 [text|+ define external ccc i1 @func() {+ start:+ ret i1 0+ }+ |]++ it "supports 'int8' for creating i8 values" $ do+ let ir = do+ function "func" [] i8 $ \[] -> do+ ret (int8 15)+ checkIR ir [text|+ define external ccc i8 @func() {+ start:+ ret i8 15+ }+ |]++ it "supports 'int16' for creating i16 values" $ do+ let ir = do+ function "func" [] i16 $ \[] -> do+ ret (int16 30)+ checkIR ir [text|+ define external ccc i16 @func() {+ start:+ ret i16 30+ }+ |]++ it "supports 'int32' for creating i32 values" $ do+ let ir = do+ function "func" [] i32 $ \[] -> do+ ret (int32 60)+ checkIR ir [text|+ define external ccc i32 @func() {+ start:+ ret i32 60+ }+ |]++ it "supports 'int64' for creating i64 values" $ do+ let ir = do+ function "func" [] i64 $ \[] -> do+ ret (int64 120)+ checkIR ir [text|+ define external ccc i64 @func() {+ start:+ ret i64 120+ }+ |]++ it "supports 'intN' for creating iN values" $ do+ let ir = do+ function "func" [] (IntType 42) $ \[] -> do+ ret (intN 42 1000)+ checkIR ir [text|+ define external ccc i42 @func() {+ start:+ ret i42 1000+ }+ |]++ it "supports 'nullPtr' for creating null values" $ do+ let ir = do+ function "func" [] (ptr i8) $ \[] -> do+ ret $ nullPtr i8+ checkIR ir [text|+ define external ccc ptr @func() {+ start:+ ret ptr zeroinitializer+ }+ |]++ describe "function attributes" $ parallel $ do+ let checkAttr attr attrStr =+ it ("supports " <> T.unpack attrStr) $ do+ let ir = withFunctionAttributes (const [attr]) $+ function "func" [] (IntType 42) $ \[] -> do+ ret (intN 42 1000)+ checkIR ir [text|+ define external ccc i42 @func() $attrStr {+ start:+ ret i42 1000+ }+ |]++ checkAttr AlwaysInline "alwaysinline"+ checkAttr (WasmExportName "test") "\"wasm-export-name\"=\"test\""++ it "supports multiple function attributes" $ do+ let attrs = [AlwaysInline, WasmExportName "test"]+ ir = withFunctionAttributes (const attrs) $+ function "func" [] (IntType 42) $ \[] -> do+ ret (intN 42 1000)+ checkIR ir [text|+ define external ccc i42 @func() alwaysinline "wasm-export-name"="test" {+ start:+ ret i42 1000+ }+ |]
+ tests/Test/LLVM/Codegen/IRCombinatorsSpec.hs view
@@ -0,0 +1,374 @@+{-# LANGUAGE QuasiQuotes, RecursiveDo, OverloadedLists #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Test.LLVM.Codegen.IRCombinatorsSpec+ ( module Test.LLVM.Codegen.IRCombinatorsSpec+ ) where++import Test.Hspec+import Data.Foldable (for_)+import LLVM.Codegen+import Data.Text (Text)+import NeatInterpolation++checkIR :: ModuleBuilder a -> Text -> IO ()+checkIR llvmModule expectedOutput = do+ let ir = ppllvm $ runModuleBuilder llvmModule+ ir `shouldBe` expectedOutput++spec :: Spec+spec = describe "IR builder combinators" $ parallel $ do+ it "supports comparisons combinators" $ do+ let scenarios :: [(Operand -> Operand -> IRBuilderT ModuleBuilder Operand, Text)]+ scenarios = [ (eq, "eq"), (ne, "ne")+ , (sge, "sge"), (sgt, "sgt"), (slt, "slt"), (sle, "sle")+ , (uge, "uge"), (ugt, "ugt"), (ult, "ult"), (ule, "ule")+ ]+ for_ scenarios $ \(f, op) -> do+ let ir = do+ function "func" [(i32, "a"), (i32, "b")] i1 $ \[a, b] -> do+ c <- f a b+ ret c+ checkIR ir [text|+ define external ccc i1 @func(i32 %a_0, i32 %b_0) {+ start:+ %0 = icmp $op i32 %a_0, %b_0+ ret i1 %0+ }+ |]++ it "supports 'one-sided if' combinator" $ do+ let ir = do+ function "func" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> mdo+ isZero <- eq a (int32 0)+ if' isZero $ do+ _ <- add a b+ ret $ int32 1000++ ret b+ checkIR ir [text|+ define external ccc i32 @func(i32 %a_0, i32 %b_0) {+ start:+ %0 = icmp eq i32 %a_0, 0+ br i1 %0, label %if_0, label %end_if_0+ if_0:+ %1 = add i32 %a_0, %b_0+ ret i32 1000+ end_if_0:+ ret i32 %b_0+ }+ |]++ it "supports 'loop' combinator" $ do+ let ir = do+ function "func" [] i32 $ \_ -> mdo+ i <- allocate i32 (int32 0)++ loop $ do+ iValue <- load i 0+ isEqual <- iValue `eq` int32 10+ if' isEqual $ do+ br end++ end <- blockNamed "end"+ ret $ int32 42+ checkIR ir [text|+ define external ccc i32 @func() {+ start:+ %stack.ptr_0 = alloca i32+ store i32 0, ptr %stack.ptr_0+ br label %loop_0+ loop_0:+ %0 = load i32, ptr %stack.ptr_0+ %1 = icmp eq i32 %0, 10+ br i1 %1, label %if_0, label %end_if_0+ if_0:+ br label %end_0+ end_if_0:+ br label %loop_0+ end_0:+ ret i32 42+ }+ |]++ it "supports 'loopWhile' combinator" $ do+ let ir = do+ function "func" [] i32 $ \_ -> mdo+ i <- allocate i32 (int32 10)+ let notZero = do+ iVal <- load i 0+ iVal `ne` int32 0+ loopWhile notZero $ do+ iVal <- load i 0+ iVal' <- sub iVal (int32 1)+ store i 0 iVal'++ ret $ int32 42+ checkIR ir [text|+ define external ccc i32 @func() {+ start:+ %stack.ptr_0 = alloca i32+ store i32 10, ptr %stack.ptr_0+ br label %while_begin_0+ while_begin_0:+ %0 = load i32, ptr %stack.ptr_0+ %1 = icmp ne i32 %0, 0+ br i1 %1, label %while_body_0, label %while_end_0+ while_body_0:+ %2 = load i32, ptr %stack.ptr_0+ %3 = sub i32 %2, 1+ store i32 %3, ptr %stack.ptr_0+ br label %while_begin_0+ while_end_0:+ ret i32 42+ }+ |]++ it "supports 'loopFor' combinator" $ do+ let ir = do+ function "func" [] i32 $ \_ -> mdo+ x <- allocate i32 (int32 10)++ loopFor (int32 0) (`ult` int32 10) (add (int32 1)) $ \i -> do+ xVal <- load x 0+ xVal' <- add i xVal+ store x 0 xVal'++ ret $ int32 42+ checkIR ir [text|+ define external ccc i32 @func() {+ start:+ %stack.ptr_0 = alloca i32+ store i32 10, ptr %stack.ptr_0+ br label %for_begin_0+ for_begin_0:+ %0 = phi i32 [0, %start], [%4, %for_body_0]+ %1 = icmp ult i32 %0, 10+ br i1 %1, label %for_body_0, label %for_end_0+ for_body_0:+ %2 = load i32, ptr %stack.ptr_0+ %3 = add i32 %0, %2+ store i32 %3, ptr %stack.ptr_0+ %4 = add i32 1, %0+ br label %for_begin_0+ for_end_0:+ ret i32 42+ }+ |]++ it "supports 'pointer subtraction' combinator" $ do+ let ir = do+ function "func" [] i32 $ \_ -> mdo+ array <- alloca i32 (Just $ int32 5) 0+ ptr1 <- gep array [int32 0]+ ptr2 <- gep array [int32 3]+ _ <- pointerDiff i32 ptr1 ptr2+ ret $ int32 42+ checkIR ir [text|+ define external ccc i32 @func() {+ start:+ %stack.ptr_0 = alloca i32, i32 5+ %0 = getelementptr i32, ptr %stack.ptr_0, i32 0+ %1 = getelementptr i32, ptr %stack.ptr_0, i32 3+ %2 = ptrtoint ptr %0 to i64+ %3 = ptrtoint ptr %1 to i64+ %4 = sub i64 %2, %3+ %5 = trunc i64 %4 to i32+ ret i32 42+ }+ |]++ it "supports logical not" $ do+ let ir = do+ function "func" [] i32 $ \_ -> mdo+ _ <- not' $ bit 0+ ret $ int32 42+ checkIR ir [text|+ define external ccc i32 @func() {+ start:+ %0 = select i1 0, i1 0, i1 1+ ret i32 42+ }+ |]++ it "supports computing the minimum of 2 values" $ do+ let ir = do+ function "func" [] i32 $ \_ -> mdo+ _result1 <- minimum' Signed (int32 100) (int32 42)+ _result2 <- minimum' Unsigned (int32 100) (int32 42)+ ret $ int32 42+ checkIR ir [text|+ define external ccc i32 @func() {+ start:+ %0 = icmp slt i32 100, 42+ %1 = select i1 %0, i32 100, i32 42+ %2 = icmp ult i32 100, 42+ %3 = select i1 %2, i32 100, i32 42+ ret i32 42+ }+ |]++ it "supports allocating and initializing a variable on the stack" $ do+ let ir = do+ function "func" [] i32 $ \_ -> mdo+ _i <- allocate i32 (int32 0)+ ret $ int32 42+ checkIR ir [text|+ define external ccc i32 @func() {+ start:+ %stack.ptr_0 = alloca i32+ store i32 0, ptr %stack.ptr_0+ ret i32 42+ }+ |]++ it "supports composing Paths" $ do+ let path = mkPath [int32 1, int32 2] ->> mkPath [int32 3]+ path `shouldBe` Path [int32 0, int32 1, int32 2, int32 3]++ it "supports computing the address based on a Path" $ do+ let path = Path [int32 5]+ ir = do+ function "func" [] i32 $ \_ -> mdo+ array <- alloca i32 (Just $ int32 5) 0+ _address <- addr path array+ ret $ int32 42+ checkIR ir [text|+ define external ccc i32 @func() {+ start:+ %stack.ptr_0 = alloca i32, i32 5+ %0 = getelementptr i32, ptr %stack.ptr_0, i32 5+ ret i32 42+ }+ |]++ it "supports dereferencing an address based on a Path" $ do+ let path = Path [int32 5]+ ir = mdo+ function "func" [] i32 $ \_ -> mdo+ array <- alloca i32 (Just $ int32 5) 0+ _value <- deref path array+ ret $ int32 42+ checkIR ir [text|+ define external ccc i32 @func() {+ start:+ %stack.ptr_0 = alloca i32, i32 5+ %0 = getelementptr i32, ptr %stack.ptr_0, i32 5+ %1 = load i32, ptr %0+ ret i32 42+ }+ |]++ it "supports storing a value at an address based on a Path" $ do+ let path = Path [int32 5]+ ir = mdo+ function "func" [] i32 $ \_ -> mdo+ array <- alloca i32 (Just $ int32 5) 0+ assign path array (int32 1000)+ ret $ int32 42+ checkIR ir [text|+ define external ccc i32 @func() {+ start:+ %stack.ptr_0 = alloca i32, i32 5+ %0 = getelementptr i32, ptr %stack.ptr_0, i32 5+ store i32 1000, ptr %0+ ret i32 42+ }+ |]++ it "supports updating a value at an address based on a Path" $ do+ let path = Path [int32 5]+ ir = mdo+ function "func" [] i32 $ \_ -> mdo+ array <- alloca i32 (Just $ int32 5) 0+ assign path array (int32 1000)+ update path array (add (int32 10))+ ret $ int32 42+ checkIR ir [text|+ define external ccc i32 @func() {+ start:+ %stack.ptr_0 = alloca i32, i32 5+ %0 = getelementptr i32, ptr %stack.ptr_0, i32 5+ store i32 1000, ptr %0+ %1 = getelementptr i32, ptr %stack.ptr_0, i32 5+ %2 = load i32, ptr %1+ %3 = add i32 10, %2+ store i32 %3, ptr %1+ ret i32 42+ }+ |]++ it "supports incrementing a value at an address based on a Path" $ do+ let path = Path [int32 5]+ ir = mdo+ function "func" [] i32 $ \_ -> mdo+ array <- alloca i32 (Just $ int32 5) 0+ assign path array (int32 1000)+ increment int32 path array+ ret $ int32 42+ checkIR ir [text|+ define external ccc i32 @func() {+ start:+ %stack.ptr_0 = alloca i32, i32 5+ %0 = getelementptr i32, ptr %stack.ptr_0, i32 5+ store i32 1000, ptr %0+ %1 = getelementptr i32, ptr %stack.ptr_0, i32 5+ %2 = load i32, ptr %1+ %3 = add i32 1, %2+ store i32 %3, ptr %1+ ret i32 42+ }+ |]++ it "supports copying (part of) a type based on a Path" $ do+ let path = Path [int32 5]+ ir = mdo+ function "func" [] i32 $ \_ -> mdo+ array <- alloca i32 (Just $ int32 5) 0+ assign path array (int32 1000)+ array2 <- alloca i32 (Just $ int32 5) 0+ copy path array array2+ ret $ int32 42+ checkIR ir [text|+ define external ccc i32 @func() {+ start:+ %stack.ptr_0 = alloca i32, i32 5+ %stack.ptr_1 = alloca i32, i32 5+ %0 = getelementptr i32, ptr %stack.ptr_0, i32 5+ store i32 1000, ptr %0+ %1 = getelementptr i32, ptr %stack.ptr_0, i32 5+ %2 = load i32, ptr %1+ %3 = getelementptr i32, ptr %stack.ptr_1, i32 5+ store i32 %2, ptr %3+ ret i32 42+ }+ |]++ it "supports swapping (part of) a type based on a Path" $ do+ let path = Path [int32 5]+ ir = mdo+ function "func" [] i32 $ \_ -> mdo+ array <- alloca i32 (Just $ int32 5) 0+ assign path array (int32 1000)+ array2 <- alloca i32 (Just $ int32 5) 0+ swap path array array2+ ret $ int32 42+ checkIR ir [text|+ define external ccc i32 @func() {+ start:+ %stack.ptr_0 = alloca i32, i32 5+ %stack.ptr_1 = alloca i32, i32 5+ %0 = getelementptr i32, ptr %stack.ptr_0, i32 5+ store i32 1000, ptr %0+ %1 = getelementptr i32, ptr %stack.ptr_0, i32 5+ %2 = load i32, ptr %1+ %3 = getelementptr i32, ptr %stack.ptr_1, i32 5+ %4 = load i32, ptr %3+ %5 = getelementptr i32, ptr %stack.ptr_0, i32 5+ store i32 %4, ptr %5+ %6 = getelementptr i32, ptr %stack.ptr_1, i32 5+ store i32 %2, ptr %6+ ret i32 42+ }+ |]+
+ tests/test.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -Wno-missing-export-lists #-}+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}