diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,24 @@ +# llvm-codegen + +[![build](https://github.com/luc-tielen/llvm-codegen/actions/workflows/ci.yml/badge.svg)](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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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 + } diff --git a/lib/LLVM/C/API.hs b/lib/LLVM/C/API.hs new file mode 100644 --- /dev/null +++ b/lib/LLVM/C/API.hs @@ -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 diff --git a/lib/LLVM/C/Bindings.hs b/lib/LLVM/C/Bindings.hs new file mode 100644 --- /dev/null +++ b/lib/LLVM/C/Bindings.hs @@ -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) diff --git a/lib/LLVM/Codegen.hs b/lib/LLVM/Codegen.hs new file mode 100644 --- /dev/null +++ b/lib/LLVM/Codegen.hs @@ -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 #-} diff --git a/lib/LLVM/Codegen/Flag.hs b/lib/LLVM/Codegen/Flag.hs new file mode 100644 --- /dev/null +++ b/lib/LLVM/Codegen/Flag.hs @@ -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 diff --git a/lib/LLVM/Codegen/IR.hs b/lib/LLVM/Codegen/IR.hs new file mode 100644 --- /dev/null +++ b/lib/LLVM/Codegen/IR.hs @@ -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 #-} diff --git a/lib/LLVM/Codegen/IRBuilder.hs b/lib/LLVM/Codegen/IRBuilder.hs new file mode 100644 --- /dev/null +++ b/lib/LLVM/Codegen/IRBuilder.hs @@ -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 diff --git a/lib/LLVM/Codegen/IRBuilder/Monad.hs b/lib/LLVM/Codegen/IRBuilder/Monad.hs new file mode 100644 --- /dev/null +++ b/lib/LLVM/Codegen/IRBuilder/Monad.hs @@ -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 #-} diff --git a/lib/LLVM/Codegen/ModuleBuilder.hs b/lib/LLVM/Codegen/ModuleBuilder.hs new file mode 100644 --- /dev/null +++ b/lib/LLVM/Codegen/ModuleBuilder.hs @@ -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 #-} diff --git a/lib/LLVM/Codegen/Name.hs b/lib/LLVM/Codegen/Name.hs new file mode 100644 --- /dev/null +++ b/lib/LLVM/Codegen/Name.hs @@ -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 #-} diff --git a/lib/LLVM/Codegen/Operand.hs b/lib/LLVM/Codegen/Operand.hs new file mode 100644 --- /dev/null +++ b/lib/LLVM/Codegen/Operand.hs @@ -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 #-} diff --git a/lib/LLVM/Codegen/Type.hs b/lib/LLVM/Codegen/Type.hs new file mode 100644 --- /dev/null +++ b/lib/LLVM/Codegen/Type.hs @@ -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 #-} diff --git a/lib/LLVM/Pretty.hs b/lib/LLVM/Pretty.hs new file mode 100644 --- /dev/null +++ b/lib/LLVM/Pretty.hs @@ -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 #-} diff --git a/llvm-codegen.cabal b/llvm-codegen.cabal new file mode 100644 --- /dev/null +++ b/llvm-codegen.cabal @@ -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 diff --git a/tests/Test/LLVM/C/APISpec.hs b/tests/Test/LLVM/C/APISpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/LLVM/C/APISpec.hs @@ -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 diff --git a/tests/Test/LLVM/Codegen/IRBuilderSpec.hs b/tests/Test/LLVM/Codegen/IRBuilderSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/LLVM/Codegen/IRBuilderSpec.hs @@ -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 + } + |] diff --git a/tests/Test/LLVM/Codegen/IRCombinatorsSpec.hs b/tests/Test/LLVM/Codegen/IRCombinatorsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/LLVM/Codegen/IRCombinatorsSpec.hs @@ -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 + } + |] + diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 --- /dev/null +++ b/tests/test.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -Wno-missing-export-lists #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}