├── .envrc ├── .github └── workflows │ └── ci.yml ├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── flake.lock ├── flake.nix ├── hie.yaml ├── lib └── LLVM │ ├── C │ ├── API.hs │ └── Bindings.hs │ ├── Codegen.hs │ ├── Codegen │ ├── Flag.hs │ ├── IR.hs │ ├── IRBuilder.hs │ ├── IRBuilder │ │ └── Monad.hs │ ├── ModuleBuilder.hs │ ├── Name.hs │ ├── Operand.hs │ └── Type.hs │ └── Pretty.hs ├── llvm-codegen.cabal └── tests ├── Test └── LLVM │ ├── C │ └── APISpec.hs │ └── Codegen │ ├── IRBuilderSpec.hs │ └── IRCombinatorsSpec.hs └── test.hs /.envrc: -------------------------------------------------------------------------------- 1 | use flake 2 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | on: [push, pull_request] 3 | 4 | permissions: 5 | contents: read 6 | 7 | jobs: 8 | build: 9 | name: GHC ${{ matrix.ghc-version }} on ${{ matrix.os }} 10 | runs-on: ${{ matrix.os }} 11 | strategy: 12 | fail-fast: false 13 | matrix: 14 | os: [ubuntu-latest, macos-latest] 15 | ghc-version: ["9.2.7", "9.4.4", "9.6.1"] 16 | 17 | steps: 18 | - uses: actions/checkout@v3 19 | 20 | - name: Set up GHC ${{ matrix.ghc-version }} 21 | uses: haskell-actions/setup@v2 22 | id: setup 23 | with: 24 | ghc-version: ${{ matrix.ghc-version }} 25 | # Defaults, added for clarity: 26 | cabal-version: "latest" 27 | cabal-update: true 28 | 29 | - name: Set up LLVM 30 | run: | 31 | echo "Installing llvm-17 on $RUNNER_OS" 32 | if [ "$RUNNER_OS" == "macOS" ]; then 33 | brew update 34 | brew install llvm@17 35 | else 36 | wget https://apt.llvm.org/llvm.sh 37 | chmod +x llvm.sh 38 | sudo ./llvm.sh 17 39 | fi 40 | 41 | - name: Installed minor versions of GHC and Cabal 42 | shell: bash 43 | run: | 44 | GHC_VERSION=$(ghc --numeric-version) 45 | CABAL_VERSION=$(cabal --numeric-version) 46 | echo "GHC_VERSION=${GHC_VERSION}" >> "${GITHUB_ENV}" 47 | echo "CABAL_VERSION=${CABAL_VERSION}" >> "${GITHUB_ENV}" 48 | cabal install hspec-discover 49 | 50 | - name: Configure the build 51 | run: | 52 | cabal configure --enable-tests --enable-benchmarks --disable-documentation 53 | cabal build --dry-run 54 | # The last step generates dist-newstyle/cache/plan.json for the cache key. 55 | 56 | - name: Restore cached dependencies 57 | uses: actions/cache/restore@v3 58 | id: cache 59 | with: 60 | path: ${{ steps.setup.outputs.cabal-store }} 61 | key: ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-cabal-${{ env.CABAL_VERSION }}-plan-${{ hashFiles('**/plan.json') }} 62 | restore-keys: | 63 | ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-cabal-${{ env.CABAL_VERSION }}- 64 | 65 | - name: Install dependencies 66 | run: cabal build all --only-dependencies 67 | 68 | # Cache dependencies already here, so that we do not have to rebuild them should the subsequent steps fail. 69 | - name: Save cached dependencies 70 | uses: actions/cache/save@v3 71 | # Caches are immutable, trying to save with the same key would error. 72 | if: ${{ steps.cache.outputs.cache-primary-key != steps.cache.outputs.cache-matched-key }} 73 | with: 74 | path: ${{ steps.setup.outputs.cabal-store }} 75 | key: ${{ steps.cache.outputs.cache-primary-key }} 76 | 77 | - name: Build 78 | run: | 79 | if [ "$RUNNER_OS" == "macOS" ]; then 80 | export PATH="/opt/homebrew/opt/llvm@17/bin:$PATH" 81 | export LDFLAGS="-L/opt/homebrew/opt/llvm@17/lib" 82 | export CPPFLAGS="-I/opt/homebrew/opt/llvm@17/include" 83 | llvm-config --version 84 | fi 85 | cabal build all 86 | 87 | - name: Run tests 88 | run: | 89 | if [ "$RUNNER_OS" == "macOS" ]; then 90 | export PATH="/opt/homebrew/opt/llvm@17/bin:$PATH" 91 | export LDFLAGS="-L/opt/homebrew/opt/llvm@17/lib" 92 | export CPPFLAGS="-I/opt/homebrew/opt/llvm@17/include" 93 | llvm-config --version 94 | fi 95 | cabal test all 96 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle/ 2 | .direnv 3 | cabal.project.local 4 | result 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Luc Tielen (c) 2022 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Luc Tielen nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | build: configure 2 | @cabal build all 3 | 4 | configure: 5 | @cabal configure --enable-tests 6 | 7 | clean: 8 | @cabal clean 9 | 10 | test: build 11 | @cabal test all 12 | 13 | cabal-file: 14 | @cabal-fmt --Werror -i llvm-codegen.cabal 15 | 16 | .PHONY: build configure clean test cabal-file 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # llvm-codegen 2 | 3 | [![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) 4 | 5 | A Haskell library for generating LLVM code. Inspired by the `llvm-hs`, 6 | `llvm-hs-pure`, `llvm-hs-combinators` and the `llvm-hs-pretty` libraries. 7 | 8 | **NOTE:** WIP, but if you only need the provided instructions it's usable (and 9 | tested). Used inside the [eclair compiler](https://github.com/luc-tielen/eclair-lang.git). 10 | 11 | Note that it requires LLVM to be installed on your system and available on your 12 | `$PATH`! 13 | 14 | ## Why another LLVM library? 15 | 16 | - Support for the latest LLVM (!) 17 | - Support for latest GHCs 18 | 19 | ## TODO 20 | 21 | - [ ] Add support for remaining instructions as needed 22 | - [ ] SIMD support, combinators 23 | - [ ] Support API with more compile time checks? 24 | - [ ] Documentation 25 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | -- NOTE: Copied from the llvm-hs project. Only modification is the LLVM version. 2 | 3 | {-# LANGUAGE CPP, FlexibleInstances #-} 4 | import Control.Exception (SomeException, try) 5 | import Control.Monad 6 | import Data.Char 7 | import Data.List 8 | import Data.Maybe 9 | import Data.Monoid 10 | import Distribution.PackageDescription hiding (buildInfo, includeDirs) 11 | import Distribution.Simple 12 | import Distribution.Simple.LocalBuildInfo 13 | import Distribution.Simple.PreProcess 14 | import Distribution.Simple.Program 15 | import Distribution.Simple.Setup hiding (Flag) 16 | import Distribution.System 17 | import System.Environment 18 | 19 | #ifdef MIN_VERSION_Cabal 20 | #if MIN_VERSION_Cabal(2,0,0) 21 | #define MIN_VERSION_Cabal_2_0_0 22 | #endif 23 | #endif 24 | 25 | -- define these selectively in C files (we are _not_ using HsFFI.h), 26 | -- rather than universally in the ccOptions, because HsFFI.h currently defines them 27 | -- without checking they're already defined and so causes warnings. 28 | uncheckedHsFFIDefines :: [String] 29 | uncheckedHsFFIDefines = ["__STDC_LIMIT_MACROS"] 30 | 31 | #ifndef MIN_VERSION_Cabal_2_0_0 32 | mkVersion :: [Int] -> Version 33 | mkVersion ver = Version ver [] 34 | versionNumbers :: Version -> [Int] 35 | versionNumbers = versionBranch 36 | mkFlagName :: String -> FlagName 37 | mkFlagName = FlagName 38 | #endif 39 | 40 | #if !(MIN_VERSION_Cabal(2,1,0)) 41 | lookupFlagAssignment :: FlagName -> FlagAssignment -> Maybe Bool 42 | lookupFlagAssignment = lookup 43 | #endif 44 | 45 | supportedLLVMVersions :: [Version] 46 | supportedLLVMVersions = 47 | [ mkVersion [17,99,99] -- TODO find a proper fix for this so all versions of 17 are allowed 48 | , mkVersion [16,0,0] 49 | , mkVersion [15,0,0] 50 | ] 51 | 52 | -- Ordered by decreasing specificty so we will prefer llvm-config-17.0 53 | -- over llvm-config-17 over llvm-config. Also looks for newer LLVM versions first 54 | llvmConfigNames :: [String] 55 | llvmConfigNames = reverse versionedConfigs ++ ["llvm-config"] 56 | where 57 | versionSuffixes :: [[Int]] 58 | versionSuffixes = 59 | concatMap (\v -> tail (inits (versionNumbers v))) supportedLLVMVersions 60 | versionedConfigs = 61 | map (\vs -> "llvm-config-" <> intercalate "." (map show vs)) versionSuffixes 62 | 63 | findJustBy :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b) 64 | findJustBy f (x:xs) = do 65 | x' <- f x 66 | case x' of 67 | Nothing -> findJustBy f xs 68 | j -> return j 69 | findJustBy _ [] = return Nothing 70 | 71 | llvmProgram :: Program 72 | llvmProgram = (simpleProgram "llvm-config") { 73 | programFindLocation = \v p -> findJustBy (\n -> programFindLocation (simpleProgram n) v p) llvmConfigNames, 74 | programFindVersion = \verbosity path -> 75 | let 76 | stripVcsSuffix = takeWhile (\c -> isDigit c || c == '.') 77 | trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse 78 | in findProgramVersion "--version" (stripVcsSuffix . trim) verbosity path 79 | } 80 | 81 | betweenVersions :: Version -> Version -> VersionRange 82 | betweenVersions minVersion maxVersion = 83 | intersectVersionRanges 84 | (orLaterVersion minVersion) 85 | (orEarlierVersion maxVersion) 86 | 87 | getLLVMConfig :: ConfigFlags -> IO ([String] -> IO String) 88 | getLLVMConfig confFlags = do 89 | let verbosity = fromFlag $ configVerbosity confFlags 90 | minVersion = minimum supportedLLVMVersions 91 | maxVersion = maximum supportedLLVMVersions 92 | -- llvm-config >= min version && <= max version 93 | versionRange = betweenVersions minVersion maxVersion 94 | (program, _, _) <- requireProgramVersion verbosity llvmProgram 95 | versionRange 96 | (configPrograms confFlags) 97 | return $ getProgramOutput verbosity program 98 | 99 | addToLdLibraryPath :: String -> IO () 100 | addToLdLibraryPath path = do 101 | let (ldLibraryPathVar, ldLibraryPathSep) = 102 | case buildOS of 103 | OSX -> ("DYLD_LIBRARY_PATH",":") 104 | _ -> ("LD_LIBRARY_PATH",":") 105 | v <- try $ getEnv ldLibraryPathVar :: IO (Either SomeException String) 106 | setEnv ldLibraryPathVar (path ++ either (const "") (ldLibraryPathSep ++) v) 107 | 108 | addLLVMToLdLibraryPath :: ConfigFlags -> IO () 109 | addLLVMToLdLibraryPath confFlags = do 110 | llvmConfig <- getLLVMConfig confFlags 111 | [libDir] <- liftM lines $ llvmConfig ["--libdir"] 112 | addToLdLibraryPath libDir 113 | 114 | -- | These flags are not relevant for us and dropping them allows 115 | -- linking against LLVM build with Clang using GCC 116 | ignoredCxxFlags :: [String] 117 | ignoredCxxFlags = ["-fcolor-diagnostics"] ++ map ("-D" ++) uncheckedHsFFIDefines 118 | 119 | ignoredCFlags :: [String] 120 | ignoredCFlags = ["-fcolor-diagnostics"] 121 | 122 | -- | Header directories are added separately to configExtraIncludeDirs 123 | isIncludeFlag :: String -> Bool 124 | isIncludeFlag flag = "-I" `isPrefixOf` flag 125 | 126 | isWarningFlag :: String -> Bool 127 | isWarningFlag flag = "-W" `isPrefixOf` flag 128 | 129 | isIgnoredCFlag :: String -> Bool 130 | isIgnoredCFlag flag = flag `elem` ignoredCFlags || isIncludeFlag flag || isWarningFlag flag 131 | 132 | isIgnoredCxxFlag :: String -> Bool 133 | isIgnoredCxxFlag flag = flag `elem` ignoredCxxFlags || isIncludeFlag flag || isWarningFlag flag 134 | 135 | main :: IO () 136 | main = do 137 | let origUserHooks = simpleUserHooks 138 | 139 | defaultMainWithHooks origUserHooks { 140 | hookedPrograms = [ llvmProgram ], 141 | 142 | confHook = \(genericPackageDescription, hookedBuildInfo) confFlags -> do 143 | llvmConfig <- getLLVMConfig confFlags 144 | llvmCxxFlags <- do 145 | rawLlvmCxxFlags <- llvmConfig ["--cxxflags"] 146 | return . filter (not . isIgnoredCxxFlag) $ words rawLlvmCxxFlags 147 | let stdLib = maybe "stdc++" 148 | (drop (length stdlibPrefix)) 149 | (find (isPrefixOf stdlibPrefix) llvmCxxFlags) 150 | where stdlibPrefix = "-stdlib=lib" 151 | includeDirs <- liftM lines $ llvmConfig ["--includedir"] 152 | libDirs <- liftM lines $ llvmConfig ["--libdir"] 153 | [llvmVersion] <- liftM lines $ llvmConfig ["--version"] 154 | let getLibs = liftM (map (fromJust . stripPrefix "-l") . words) . llvmConfig 155 | flags = configConfigurationsFlags confFlags 156 | linkFlag = case lookupFlagAssignment (mkFlagName "shared-llvm") flags of 157 | Nothing -> "--link-shared" 158 | Just shared -> if shared then "--link-shared" else "--link-static" 159 | libs <- getLibs ["--libs", linkFlag] 160 | systemLibs <- getLibs ["--system-libs", linkFlag] 161 | 162 | let genericPackageDescription' = genericPackageDescription { 163 | condLibrary = do 164 | libraryCondTree <- condLibrary genericPackageDescription 165 | return libraryCondTree { 166 | condTreeData = condTreeData libraryCondTree <> mempty { 167 | libBuildInfo = 168 | mempty { 169 | ccOptions = llvmCxxFlags, 170 | extraLibs = libs ++ stdLib : systemLibs 171 | } 172 | } 173 | } 174 | } 175 | configFlags' = confFlags { 176 | configExtraLibDirs = libDirs ++ configExtraLibDirs confFlags, 177 | configExtraIncludeDirs = includeDirs ++ configExtraIncludeDirs confFlags 178 | } 179 | addLLVMToLdLibraryPath configFlags' 180 | confHook simpleUserHooks (genericPackageDescription', hookedBuildInfo) configFlags', 181 | 182 | hookedPreProcessors = 183 | let origHookedPreprocessors = hookedPreProcessors origUserHooks 184 | #ifdef MIN_VERSION_Cabal_2_0_0 185 | newHsc buildInfo localBuildInfo componentLocalBuildInfo = 186 | #else 187 | newHsc buildInfo localBuildInfo = 188 | #endif 189 | PreProcessor 190 | { platformIndependent = platformIndependent (origHsc buildInfo) 191 | , runPreProcessor = \inFiles outFiles verbosity -> do 192 | llvmConfig <- getLLVMConfig (configFlags localBuildInfo) 193 | llvmCFlags <- do 194 | rawLlvmCFlags <- llvmConfig ["--cflags"] 195 | return . filter (not . isIgnoredCFlag) $ words rawLlvmCFlags 196 | let buildInfo' = buildInfo { ccOptions = "-Wno-variadic-macros" : llvmCFlags } 197 | runPreProcessor (origHsc buildInfo') inFiles outFiles verbosity 198 | #if MIN_VERSION_Cabal(3,8,1) 199 | , ppOrdering = \_verbosity _paths modules -> pure modules 200 | #endif 201 | } 202 | where origHsc buildInfo' = 203 | fromMaybe 204 | ppHsc2hs 205 | (lookup "hsc" origHookedPreprocessors) 206 | buildInfo' 207 | localBuildInfo 208 | #ifdef MIN_VERSION_Cabal_2_0_0 209 | componentLocalBuildInfo 210 | #endif 211 | in [("hsc", newHsc)] ++ origHookedPreprocessors, 212 | 213 | buildHook = \packageDesc localBuildInfo userHooks buildFlags -> 214 | do addLLVMToLdLibraryPath (configFlags localBuildInfo) 215 | buildHook origUserHooks packageDesc localBuildInfo userHooks buildFlags, 216 | 217 | testHook = \args packageDesc localBuildInfo userHooks testFlags -> 218 | do addLLVMToLdLibraryPath (configFlags localBuildInfo) 219 | testHook origUserHooks args packageDesc localBuildInfo userHooks testFlags 220 | } 221 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "ds": { 4 | "inputs": { 5 | "flake-utils": "flake-utils", 6 | "nixpkgs": "nixpkgs" 7 | }, 8 | "locked": { 9 | "lastModified": 1650900878, 10 | "narHash": "sha256-qhNncMBSa9STnhiLfELEQpYC1L4GrYHNIzyCZ/pilsI=", 11 | "owner": "numtide", 12 | "repo": "devshell", 13 | "rev": "d97df53b5ddaa1cfbea7cddbd207eb2634304733", 14 | "type": "github" 15 | }, 16 | "original": { 17 | "owner": "numtide", 18 | "ref": "master", 19 | "repo": "devshell", 20 | "type": "github" 21 | } 22 | }, 23 | "flake-utils": { 24 | "locked": { 25 | "lastModified": 1642700792, 26 | "narHash": "sha256-XqHrk7hFb+zBvRg6Ghl+AZDq03ov6OshJLiSWOoX5es=", 27 | "owner": "numtide", 28 | "repo": "flake-utils", 29 | "rev": "846b2ae0fc4cc943637d3d1def4454213e203cba", 30 | "type": "github" 31 | }, 32 | "original": { 33 | "owner": "numtide", 34 | "repo": "flake-utils", 35 | "type": "github" 36 | } 37 | }, 38 | "fu": { 39 | "locked": { 40 | "lastModified": 1649676176, 41 | "narHash": "sha256-OWKJratjt2RW151VUlJPRALb7OU2S5s+f0vLj4o1bHM=", 42 | "owner": "numtide", 43 | "repo": "flake-utils", 44 | "rev": "a4b154ebbdc88c8498a5c7b01589addc9e9cb678", 45 | "type": "github" 46 | }, 47 | "original": { 48 | "owner": "numtide", 49 | "ref": "master", 50 | "repo": "flake-utils", 51 | "type": "github" 52 | } 53 | }, 54 | "nf": { 55 | "locked": { 56 | "lastModified": 1661201956, 57 | "narHash": "sha256-RizGJH/buaw9A2+fiBf9WnXYw4LZABB5kMAZIEE5/T8=", 58 | "owner": "numtide", 59 | "repo": "nix-filter", 60 | "rev": "3b821578685d661a10b563cba30b1861eec05748", 61 | "type": "github" 62 | }, 63 | "original": { 64 | "owner": "numtide", 65 | "ref": "master", 66 | "repo": "nix-filter", 67 | "type": "github" 68 | } 69 | }, 70 | "nixpkgs": { 71 | "locked": { 72 | "lastModified": 1643381941, 73 | "narHash": "sha256-pHTwvnN4tTsEKkWlXQ8JMY423epos8wUOhthpwJjtpc=", 74 | "owner": "NixOS", 75 | "repo": "nixpkgs", 76 | "rev": "5efc8ca954272c4376ac929f4c5ffefcc20551d5", 77 | "type": "github" 78 | }, 79 | "original": { 80 | "owner": "NixOS", 81 | "ref": "nixpkgs-unstable", 82 | "repo": "nixpkgs", 83 | "type": "github" 84 | } 85 | }, 86 | "np": { 87 | "locked": { 88 | "lastModified": 1665993766, 89 | "narHash": "sha256-+lPrbR7AREWwXpYWku0gWtw4FwHhc/sHTkW64KZXA5o=", 90 | "owner": "nixos", 91 | "repo": "nixpkgs", 92 | "rev": "eaba04def711c69b5211d094bb5d673423121ae0", 93 | "type": "github" 94 | }, 95 | "original": { 96 | "owner": "nixos", 97 | "ref": "master", 98 | "repo": "nixpkgs", 99 | "type": "github" 100 | } 101 | }, 102 | "root": { 103 | "inputs": { 104 | "ds": "ds", 105 | "fu": "fu", 106 | "nf": "nf", 107 | "np": "np" 108 | } 109 | } 110 | }, 111 | "root": "root", 112 | "version": 7 113 | } 114 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "llvm-codegen: LLVM code generation using Haskell"; 3 | inputs = { 4 | np.url = "github:nixos/nixpkgs?ref=master"; 5 | fu.url = "github:numtide/flake-utils?ref=master"; 6 | ds.url = "github:numtide/devshell?ref=master"; 7 | nf.url = "github:numtide/nix-filter?ref=master"; 8 | }; 9 | outputs = { self, np, fu, ds, nf, ... }@inputs: 10 | with np.lib; 11 | with fu.lib; 12 | eachSystem [ "x86_64-linux" "x86_64-darwin" ] (system: 13 | let 14 | ghcVersion = "902"; 15 | llvmVersion = 14; 16 | version = "${ghcVersion}.${substring 0 8 self.lastModifiedDate}.${ 17 | self.shortRev or "dirty" 18 | }"; 19 | config = { }; 20 | overlay = final: _: 21 | let 22 | haskellPackages = 23 | final.haskell.packages."ghc${ghcVersion}".override { 24 | overrides = with final.haskell.lib; 25 | hf: hp: 26 | let llvm = final."llvmPackages_${toString llvmVersion}".llvm; 27 | in { 28 | llvm-codegen = appendConfigureFlags 29 | ((hf.callCabal2nix "llvm-codegen" (with nf.lib; 30 | filter { 31 | root = self; 32 | exclude = [ ("Setup.hs") ]; 33 | }) { llvm-config = llvm; }).overrideAttrs (old: { 34 | version = "${old.version}-${version}"; 35 | })) [ 36 | "--ghc-option=-optl=-L/${llvm}/lib" 37 | "--ghc-option=-optl=-I/${llvm}/include" 38 | "--ghc-option=-optl=-lLLVM-${toString llvmVersion}" 39 | ]; 40 | }; 41 | }; 42 | in { inherit haskellPackages; }; 43 | 44 | pkgs = import np { 45 | inherit config; 46 | system = if system == "aarch64-darwin" 47 | then "x86_64-darwin" 48 | else system; 49 | overlays = [ overlay ds.overlay ]; 50 | }; 51 | in with pkgs.lib; rec { 52 | inherit overlay; 53 | packages = { inherit (pkgs.haskellPackages) llvm-codegen; }; 54 | defaultPackage = packages.llvm-codegen; 55 | devShell = pkgs.devshell.mkShell { 56 | name = "llvm-codegen"; 57 | imports = [ ]; 58 | packages = with pkgs; 59 | with haskellPackages; [ 60 | pkgs."llvmPackages_${toString llvmVersion}".llvm.dev 61 | pkgs.ghcid 62 | (ghcWithPackages (p: 63 | with p; [ 64 | hspec-discover 65 | ghc 66 | cabal-install 67 | hsc2hs 68 | hpack 69 | haskell-language-server 70 | ])) 71 | ]; 72 | }; 73 | }); 74 | } 75 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | - path: "lib" 4 | component: "lib:llvm-codegen" 5 | 6 | - path: "tests" 7 | component: "llvm-codegen:test:llvm-codegen-test" 8 | -------------------------------------------------------------------------------- /lib/LLVM/C/API.hs: -------------------------------------------------------------------------------- 1 | module LLVM.C.API 2 | ( Context 3 | , Module 4 | , TargetData 5 | , Type 6 | , mkContext 7 | , mkModule 8 | , mkTargetData 9 | , setTargetData 10 | , getTargetData 11 | , sizeOfType 12 | 13 | , getTypeByName 14 | , mkVoidType 15 | , mkIntType 16 | , mkPointerType 17 | , mkArrayType 18 | , mkFunctionType 19 | , mkAnonStructType 20 | , mkOpaqueStructType 21 | , setNamedStructBody 22 | ) where 23 | 24 | import Data.Word 25 | import Foreign.C 26 | import Foreign.Ptr 27 | import Foreign.ForeignPtr 28 | import Foreign.Marshal.Array 29 | import Control.Exception 30 | import Data.Text (Text) 31 | import qualified Data.Text as T 32 | import LLVM.C.Bindings 33 | import LLVM.Codegen.Name 34 | import LLVM.Codegen.Flag 35 | import qualified LLVM.Codegen.Type as LLVMType 36 | 37 | 38 | mkVoidType :: ForeignPtr Context -> IO (Ptr Type) 39 | mkVoidType ctx = withForeignPtr ctx llvmVoidTypeInContext 40 | 41 | mkIntType :: ForeignPtr Context -> Word32 -> IO (Ptr Type) 42 | mkIntType ctx bits = withForeignPtr ctx $ \c -> 43 | case bits of 44 | 1 -> llvmI1TypeInContext c 45 | 8 -> llvmI8TypeInContext c 46 | 16 -> llvmI16TypeInContext c 47 | 32 -> llvmI32TypeInContext c 48 | 64 -> llvmI64TypeInContext c 49 | _ -> llvmIntTypeInContext c (CUInt bits) 50 | 51 | mkPointerType :: Ptr Type -> IO (Ptr Type) 52 | mkPointerType pointeeTy = 53 | llvmPointerTypeInContext pointeeTy 0 54 | 55 | mkAnonStructType :: ForeignPtr Context -> [Ptr Type] -> Flag LLVMType.Packed -> IO (Ptr Type) 56 | mkAnonStructType ctx tys packed = 57 | withForeignPtr ctx $ \c -> 58 | withArray tys $ \tyArray -> do 59 | let count = CUInt $ fromIntegral $ length tys 60 | packed' = CBool (if packed == On then 1 else 0) 61 | llvmStructTypeInContext c tyArray count packed' 62 | 63 | -- NOTE: can be used to forward declare a struct type 64 | mkOpaqueStructType :: ForeignPtr Context -> Name -> IO (Ptr Type) 65 | mkOpaqueStructType ctx name = 66 | withForeignPtr ctx $ \c -> 67 | withNameAsCString name $ \nm -> 68 | llvmNamedStructTypeInContext c nm 69 | 70 | withNameAsCString :: Name -> (CString -> IO a) -> IO a 71 | withNameAsCString name = 72 | withCString (T.unpack $ unName name) 73 | 74 | -- NOTE: call this on a Type returned by 'mkOpaqueStructType' to define the struct body of that type. 75 | setNamedStructBody :: Ptr Type -> [Ptr Type] -> Flag LLVMType.Packed -> IO () 76 | setNamedStructBody structTy tys packed = 77 | withArray tys $ \tyArray -> do 78 | let count = CUInt $ fromIntegral $ length tys 79 | packed' = CBool (if packed == On then 1 else 0) 80 | llvmNamedStructSetBody structTy tyArray count packed' 81 | 82 | mkArrayType :: Ptr Type -> Word32 -> IO (Ptr Type) 83 | mkArrayType elemTy count = 84 | llvmArrayTypeInContext elemTy (CUInt count) 85 | 86 | mkFunctionType :: Ptr Type -> [Ptr Type] -> IO (Ptr Type) 87 | mkFunctionType retTy argTys = 88 | withArray argTys $ \argTyArray -> do 89 | let argCount = CUInt $ fromIntegral $ length argTys 90 | isVarArg = CBool 0 91 | llvmFunctionTypeInContext retTy argTyArray argCount isVarArg 92 | 93 | getTypeByName :: ForeignPtr Context -> Name -> IO (Ptr Type) 94 | getTypeByName ctx name = 95 | withForeignPtr ctx $ \c -> 96 | withCString (T.unpack $ unName name) $ \str -> 97 | llvmGetTypeByNameInContext c str 98 | 99 | mkContext :: IO (ForeignPtr Context) 100 | mkContext = mask_ $ do 101 | ctx <- llvmContextCreate 102 | newForeignPtr llvmContextDispose ctx 103 | 104 | mkModule :: ForeignPtr Context -> Text -> IO (ForeignPtr Module) 105 | mkModule ctx name = 106 | withCString (T.unpack name) $ \name' -> do 107 | withForeignPtr ctx $ \c -> mask_ $ do 108 | llvmModule <- llvmCreateModuleWithName name' c 109 | -- TODO next line causes segfault? is this because some other field needs to get set first? or auto-cleaned up in context? 110 | -- newForeignPtr llvmDisposeModule llvmModule 111 | -- TODO: no longer need foreignptr wrapper then? 112 | newForeignPtr_ llvmModule 113 | 114 | -- NOTE: no checks are made against the datalayout 115 | mkTargetData :: String -> IO (ForeignPtr TargetData) 116 | mkTargetData dl = mask_ $ do 117 | withCString dl $ \dlStr -> do 118 | td <- llvmCreateTargetData dlStr 119 | newForeignPtr llvmDisposeTargetData td 120 | 121 | setTargetData :: ForeignPtr Module -> ForeignPtr TargetData -> IO () 122 | setTargetData llvmModule targetData = do 123 | withForeignPtr llvmModule $ \m -> 124 | withForeignPtr targetData $ \td -> 125 | llvmSetTargetData m td 126 | 127 | getTargetData :: ForeignPtr Module -> IO (Ptr TargetData) 128 | getTargetData llvmModule = 129 | withForeignPtr llvmModule llvmGetTargetData 130 | 131 | sizeOfType :: Ptr TargetData -> Ptr Type -> IO Word64 132 | sizeOfType td ty = do 133 | CSize byteSize <- llvmSizeOfType td ty 134 | pure byteSize 135 | -------------------------------------------------------------------------------- /lib/LLVM/C/Bindings.hs: -------------------------------------------------------------------------------- 1 | module LLVM.C.Bindings 2 | ( Context 3 | , Module 4 | , TargetData 5 | , Type 6 | , llvmContextCreate 7 | , llvmContextDispose 8 | , llvmCreateModuleWithName 9 | , llvmDisposeModule 10 | , llvmCreateTargetData 11 | , llvmDisposeTargetData 12 | , llvmSetTargetData 13 | , llvmGetTargetData 14 | , llvmSizeOfType 15 | , llvmVoidTypeInContext 16 | , llvmI1TypeInContext 17 | , llvmI8TypeInContext 18 | , llvmI16TypeInContext 19 | , llvmI32TypeInContext 20 | , llvmI64TypeInContext 21 | , llvmIntTypeInContext 22 | , llvmPointerTypeInContext 23 | , llvmStructTypeInContext 24 | , llvmNamedStructTypeInContext 25 | , llvmNamedStructSetBody 26 | , llvmArrayTypeInContext 27 | , llvmFunctionTypeInContext 28 | , llvmGetTypeByNameInContext 29 | ) where 30 | 31 | import Foreign.C 32 | import Foreign.Ptr 33 | 34 | 35 | -- TODO: use ReaderT (ForeignPtr Context) IO a 36 | 37 | data Context 38 | data Module 39 | data TargetData 40 | data Type 41 | 42 | foreign import ccall unsafe "LLVMContextCreate" llvmContextCreate 43 | :: IO (Ptr Context) 44 | 45 | foreign import ccall unsafe "&LLVMContextDispose" llvmContextDispose 46 | :: FunPtr (Ptr Context -> IO ()) 47 | 48 | foreign import ccall unsafe "LLVMModuleCreateWithNameInContext" llvmCreateModuleWithName 49 | :: CString -> Ptr Context -> IO (Ptr Module) 50 | 51 | foreign import ccall unsafe "&LLVMDisposeModule" llvmDisposeModule 52 | :: FunPtr (Ptr Module -> IO ()) 53 | 54 | foreign import ccall unsafe "LLVMCreateTargetData" llvmCreateTargetData 55 | :: CString -> IO (Ptr TargetData) 56 | 57 | foreign import ccall unsafe "&LLVMDisposeTargetData" llvmDisposeTargetData 58 | :: FunPtr (Ptr TargetData -> IO ()) 59 | 60 | foreign import ccall unsafe "LLVMSetModuleDataLayout" llvmSetTargetData 61 | :: Ptr Module -> Ptr TargetData -> IO () 62 | 63 | foreign import ccall unsafe "LLVMGetModuleDataLayout" llvmGetTargetData 64 | :: Ptr Module -> IO (Ptr TargetData) 65 | 66 | foreign import ccall unsafe "LLVMABISizeOfType" llvmSizeOfType 67 | :: Ptr TargetData -> Ptr Type -> IO CSize 68 | 69 | foreign import ccall unsafe "LLVMVoidTypeInContext" llvmVoidTypeInContext 70 | :: Ptr Context -> IO (Ptr Type) 71 | 72 | foreign import ccall unsafe "LLVMInt1TypeInContext" llvmI1TypeInContext 73 | :: Ptr Context -> IO (Ptr Type) 74 | 75 | foreign import ccall unsafe "LLVMInt8TypeInContext" llvmI8TypeInContext 76 | :: Ptr Context -> IO (Ptr Type) 77 | 78 | foreign import ccall unsafe "LLVMInt16TypeInContext" llvmI16TypeInContext 79 | :: Ptr Context -> IO (Ptr Type) 80 | 81 | foreign import ccall unsafe "LLVMInt32TypeInContext" llvmI32TypeInContext 82 | :: Ptr Context -> IO (Ptr Type) 83 | 84 | foreign import ccall unsafe "LLVMInt64TypeInContext" llvmI64TypeInContext 85 | :: Ptr Context -> IO (Ptr Type) 86 | 87 | foreign import ccall unsafe "LLVMIntTypeInContext" llvmIntTypeInContext 88 | :: Ptr Context -> CUInt -> IO (Ptr Type) 89 | 90 | foreign import ccall unsafe "LLVMPointerType" llvmPointerTypeInContext 91 | :: Ptr Type -> CUInt -> IO (Ptr Type) 92 | 93 | foreign import ccall unsafe "LLVMStructTypeInContext" llvmStructTypeInContext 94 | :: Ptr Context -> Ptr (Ptr Type) -> CUInt -> CBool -> IO (Ptr Type) 95 | 96 | foreign import ccall unsafe "LLVMStructCreateNamed" llvmNamedStructTypeInContext 97 | :: Ptr Context -> CString -> IO (Ptr Type) 98 | 99 | foreign import ccall unsafe "LLVMStructSetBody" llvmNamedStructSetBody 100 | :: Ptr Type -> Ptr (Ptr Type) -> CUInt -> CBool -> IO () 101 | 102 | foreign import ccall unsafe "LLVMArrayType" llvmArrayTypeInContext 103 | :: Ptr Type -> CUInt -> IO (Ptr Type) 104 | 105 | foreign import ccall unsafe "LLVMFunctionType" llvmFunctionTypeInContext 106 | :: Ptr Type -> Ptr (Ptr Type) -> CUInt -> CBool -> IO (Ptr Type) 107 | 108 | foreign import ccall unsafe "LLVMGetTypeByName2" llvmGetTypeByNameInContext 109 | :: Ptr Context -> CString -> IO (Ptr Type) 110 | -------------------------------------------------------------------------------- /lib/LLVM/Codegen.hs: -------------------------------------------------------------------------------- 1 | module LLVM.Codegen 2 | ( module LLVM.Codegen.IRBuilder 3 | , module LLVM.Codegen.ModuleBuilder 4 | , module LLVM.Codegen.Type 5 | , module LLVM.Codegen.Operand 6 | , module LLVM.Codegen.Name 7 | , module LLVM.Codegen.IR 8 | , module LLVM.Codegen.Flag 9 | , ppllvm 10 | ) where 11 | 12 | import LLVM.Codegen.IRBuilder 13 | import LLVM.Codegen.ModuleBuilder 14 | import LLVM.Codegen.Type 15 | import LLVM.Codegen.Operand 16 | import LLVM.Codegen.Name 17 | import LLVM.Codegen.IR 18 | import LLVM.Codegen.Flag 19 | import LLVM.Pretty 20 | import Data.Text 21 | 22 | 23 | ppllvm :: Module -> Text 24 | ppllvm = renderDoc renderModule 25 | {-# INLINABLE ppllvm #-} 26 | -------------------------------------------------------------------------------- /lib/LLVM/Codegen/Flag.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RoleAnnotations #-} 2 | 3 | module LLVM.Codegen.Flag 4 | ( Flag(..) 5 | ) where 6 | 7 | data Flag a 8 | = On 9 | | Off 10 | deriving (Eq, Ord, Show) 11 | 12 | type role Flag nominal 13 | -------------------------------------------------------------------------------- /lib/LLVM/Codegen/IR.hs: -------------------------------------------------------------------------------- 1 | module LLVM.Codegen.IR 2 | ( IR(..) 3 | , Terminator(..) 4 | , ComparisonType(..) 5 | , CallingConvention(..) 6 | , TailCallAttribute(..) 7 | , SynchronizationScope(..) 8 | , MemoryOrdering(..) 9 | , Alignment 10 | , Flag(..) 11 | , NUW 12 | , NSW 13 | , Exact 14 | , Inbounds 15 | , Volatile 16 | , renderIR 17 | ) where 18 | 19 | import Prelude hiding (EQ) 20 | import LLVM.Codegen.Name 21 | import LLVM.Codegen.Operand 22 | import LLVM.Codegen.Type 23 | import LLVM.Codegen.Flag 24 | import LLVM.Pretty 25 | import Data.Word 26 | import Data.List.NonEmpty (NonEmpty(..)) 27 | import qualified Data.List.NonEmpty as NE 28 | 29 | 30 | data NUW 31 | data NSW 32 | data Exact 33 | data Inbounds 34 | data Volatile 35 | 36 | type Alignment = Word32 37 | 38 | data SynchronizationScope 39 | = SingleThread 40 | | System 41 | deriving Show 42 | 43 | data MemoryOrdering 44 | = Unordered 45 | | Monotonic 46 | | Acquire 47 | | Release 48 | | AcquireRelease 49 | | SequentiallyConsistent 50 | deriving Show 51 | 52 | type Atomicity = (SynchronizationScope, MemoryOrdering) 53 | 54 | data ComparisonType 55 | = EQ 56 | | NE 57 | | UGT 58 | | UGE 59 | | ULT 60 | | ULE 61 | | SGT 62 | | SGE 63 | | SLT 64 | | SLE 65 | deriving (Eq, Show) 66 | 67 | data TailCallAttribute 68 | = Tail 69 | | MustTail 70 | | NoTail 71 | deriving Show 72 | 73 | data CallingConvention 74 | = C 75 | | Fast 76 | -- TODO add others as needed 77 | deriving Show 78 | 79 | data IR 80 | = Add !(Flag NUW) !(Flag NSW) !Operand !Operand 81 | | Mul !(Flag NUW) !(Flag NSW) !Operand !Operand 82 | | Sub !(Flag NUW) !(Flag NSW) !Operand !Operand 83 | | Udiv !(Flag Exact) !Operand !Operand 84 | | And !Operand !Operand 85 | | Or !Operand !Operand 86 | | Trunc !Operand !Type 87 | | Zext !Operand !Type 88 | | Bitcast !Operand !Type 89 | | ICmp !ComparisonType !Operand !Operand 90 | | PtrToInt !Operand !Type 91 | | Alloca !Type !(Maybe Operand) !Int 92 | | GetElementPtr !(Flag Inbounds) !Operand ![Operand] 93 | | Load !(Flag Volatile) !Operand !(Maybe Atomicity) !Alignment 94 | | Store !(Flag Volatile) !Operand !Operand !(Maybe Atomicity) !Alignment 95 | | Phi !(NonEmpty (Operand, Name)) 96 | | Call !(Maybe TailCallAttribute) !CallingConvention !Operand ![Operand] -- TODO support param attributes 97 | -- Terminators 98 | | Ret !(Maybe Operand) 99 | | Br !Name 100 | | CondBr !Operand !Name !Name 101 | | Switch !Operand !Name ![(Operand, Name)] 102 | | Select !Operand !Operand !Operand 103 | deriving Show 104 | 105 | newtype Terminator 106 | = Terminator IR 107 | deriving Show 108 | 109 | renderTCA :: Renderer TailCallAttribute 110 | renderTCA buf = \case 111 | Tail -> buf |># "tail"# 112 | NoTail -> buf |># "notail"# 113 | MustTail -> buf |># "musttail"# 114 | {-# INLINABLE renderTCA #-} 115 | 116 | renderCC :: Renderer CallingConvention 117 | renderCC buf = \case 118 | C -> buf |># "ccc"# 119 | Fast -> buf |># "fastcc"# 120 | {-# INLINABLE renderCC #-} 121 | 122 | renderComparisonType :: Renderer ComparisonType 123 | renderComparisonType buf = \case 124 | EQ -> buf |># "eq"# 125 | NE -> buf |># "ne"# 126 | UGT -> buf |># "ugt"# 127 | UGE -> buf |># "uge"# 128 | ULT -> buf |># "ult"# 129 | ULE -> buf |># "ule"# 130 | SGT -> buf |># "sgt"# 131 | SGE -> buf |># "sge"# 132 | SLT -> buf |># "slt"# 133 | SLE -> buf |># "sle"# 134 | {-# INLINABLE renderComparisonType #-} 135 | 136 | renderMemoryOrdering :: Renderer MemoryOrdering 137 | renderMemoryOrdering buf = \case 138 | Unordered -> buf |># "unordered"# 139 | Monotonic -> buf |># "monotonic"# 140 | Acquire -> buf |># "acquire"# 141 | Release -> buf |># "release"# 142 | AcquireRelease -> buf |># "acq_rel"# 143 | SequentiallyConsistent -> buf |># "seq_cst"# 144 | {-# INLINABLE renderMemoryOrdering #-} 145 | 146 | renderSyncScope :: Renderer SynchronizationScope 147 | renderSyncScope buf = \case 148 | SingleThread -> 149 | buf |># "syncscope(\"singlethread\")"# 150 | System -> 151 | buf 152 | {-# INLINABLE renderSyncScope #-} 153 | 154 | renderIR :: Renderer IR 155 | renderIR buf = \case 156 | Add nuw nsw a b -> 157 | renderArithBinOp buf "add "# nuw nsw a b 158 | Mul nuw nsw a b -> 159 | renderArithBinOp buf "mul "# nuw nsw a b 160 | Sub nuw nsw a b -> 161 | renderArithBinOp buf "sub "# nuw nsw a b 162 | Udiv exact a b -> 163 | ((((optional exact (buf |># "udiv "#) (|># "exact "#) `renderType` typeOf a) 164 | |>. ' ') `renderOperand` a) |># ", "#) `renderOperand` b 165 | And a b -> 166 | ((((buf |># "and "#) `renderType` typeOf a) |>. ' ') `renderOperand` a |># ", "#) `renderOperand` b 167 | Or a b -> 168 | ((((buf |># "or "#) `renderType` typeOf a) |>. ' ') `renderOperand` a |># ", "#) `renderOperand` b 169 | ICmp cmp a b -> 170 | (((((buf |># "icmp "#) `renderComparisonType` cmp |>. ' ') `renderType` typeOf a) |>. ' ') `renderOperand` a |># ", "#) `renderOperand` b 171 | Trunc val to -> 172 | renderConvertOp buf "trunc "# val to 173 | Zext val to -> 174 | renderConvertOp buf "zext "# val to 175 | Bitcast val to -> 176 | renderConvertOp buf "bitcast "# val to 177 | PtrToInt val to -> 178 | renderConvertOp buf "ptrtoint "# val to 179 | Alloca ty mNumElems alignment -> 180 | renderMaybe 181 | (renderMaybe ((buf |># "alloca "#) `renderType` ty) mNumElems 182 | (\buf' count -> ((buf' |># ", "#) `renderType` typeOf count |>. ' ') `renderOperand` count)) 183 | (if alignment == 0 then Nothing else Just alignment) 184 | (\buf' align -> buf' |># ", align "# |>$ align) 185 | GetElementPtr inbounds pointer indices -> 186 | case typeOf pointer of 187 | ty@(PointerType innerTy) -> 188 | commas (((optional inbounds (buf |># "getelementptr "#) (|># "inbounds "#) `renderType` innerTy |># ", "#) `renderType` ty |>. ' ') 189 | `renderOperand` pointer |># ", "#) indices prettyIndex 190 | _ -> 191 | buf |> error "Operand given to `getelementptr` that is not a pointer!" 192 | where 193 | prettyIndex :: Buffer %1 -> Operand -> Buffer 194 | prettyIndex buf' i = (renderType buf' (typeOf i) |>. ' ') `renderOperand` i 195 | Load volatile addr atomicity alignment -> 196 | case atomicity of 197 | Nothing -> 198 | withAlignment alignment 199 | ((((optional volatile (buf |># "load "#) (|># "volatile "#) 200 | `renderType` resultTy) |># ", "#) `renderType` ptrTy |>. ' ') `renderOperand` addr) 201 | Just (syncScope, memoryOrdering) -> 202 | withAlignment alignment 203 | ((((((optional volatile (buf |># "load atomic "#) (|># "volatile "#) 204 | `renderType` resultTy) |># ", "#) `renderType` ptrTy |>. ' ') `renderOperand` addr |>. ' ') 205 | `renderSyncScope` syncScope |>. ' ') `renderMemoryOrdering` memoryOrdering) 206 | where 207 | ptrTy = typeOf addr 208 | resultTy = case ptrTy of 209 | PointerType ty -> ty 210 | _ -> error "Malformed AST, expected pointer type." 211 | Store volatile addr value atomicity alignment -> 212 | case atomicity of 213 | Nothing -> 214 | withAlignment alignment 215 | ((((optional volatile (buf |># "store "#) (|># "volatile "#) `renderType` ty |>. ' ') `renderOperand` value |># ", "#) 216 | `renderType` ptrTy |>. ' ') `renderOperand` addr) 217 | Just (syncScope, memoryOrdering) -> 218 | withAlignment alignment 219 | ((((((optional volatile (buf |># "store atomic "#) (|># "volatile "#) `renderType` ty |>. ' ') `renderOperand` value |># ", "#) 220 | `renderType` ptrTy |>. ' ') `renderOperand` addr |>. ' ') `renderSyncScope` syncScope |>. ' ') `renderMemoryOrdering` memoryOrdering) 221 | where 222 | ty = typeOf value 223 | ptrTy = PointerType ty 224 | Phi cases@((val, _) :| _) -> 225 | commas ((buf |># "phi "#) `renderType` typeOf val |>. ' ') (NE.toList cases) renderPhiCase 226 | where 227 | renderPhiCase :: Renderer (Operand, Name) 228 | renderPhiCase buf' (value, name) = 229 | brackets buf' (\buf'' -> (renderOperand buf'' value |># ", %"#) `renderName` name) 230 | Call tcAttr cc fn args -> 231 | (((renderMaybe buf tcAttr (\buf' tca -> renderTCA buf' tca |>. ' ') 232 | |># "call "#) `renderCC` cc |>. ' ') `renderType` resultType |>. ' ') 233 | `renderOperand` fn `renderArgs` args 234 | where 235 | resultType = case typeOf fn of 236 | PointerType (FunctionType retTy _) -> retTy 237 | FunctionType retTy _ -> retTy 238 | _ -> error "Malformed AST, expected function type." 239 | renderArgs :: Renderer [Operand] 240 | renderArgs buf' args' = tupled buf' args' renderArg 241 | renderArg :: Renderer Operand 242 | renderArg buf' arg = 243 | (renderType buf' (typeOf arg) |>. ' ') `renderOperand` arg 244 | Ret term -> case term of 245 | Nothing -> 246 | buf |># "ret void"# 247 | Just operand -> 248 | ((buf |># "ret "#) `renderType` typeOf operand |>. ' ') `renderOperand` operand 249 | Br blockName -> 250 | (buf |># "br label %"#) `renderName` blockName 251 | CondBr cond trueLabel falseLabel -> 252 | (((buf |># "br i1 "#) `renderOperand` cond 253 | |># ", label %"#) `renderName` trueLabel 254 | |># ", label %"#) `renderName` falseLabel 255 | Switch val defaultLabel cases -> 256 | brackets ((((buf |># "switch "#) `renderType` typeOf val |>. ' ') `renderOperand` val |># ", label %"#) `renderName` defaultLabel |>. ' ') 257 | (\buf' -> hsep buf' cases renderCase) 258 | where 259 | renderCase :: Renderer (Operand, Name) 260 | renderCase buf' (caseVal, label) = 261 | ((renderType buf' (typeOf caseVal) |>. ' ') `renderOperand` caseVal |># ", label %"#) `renderName` label 262 | Select c t f -> 263 | ((((((buf |># "select "#) `renderType` typeOf c |>. ' ') `renderOperand` c |># ", "#) 264 | `renderType` typeOf t |>. ' ') `renderOperand` t |># ", "#) 265 | `renderType` typeOf f |>. ' ') `renderOperand` f 266 | where 267 | withAlignment :: Word32 -> Buffer %1 -> Buffer 268 | withAlignment alignment buf' = 269 | if alignment == 0 270 | then buf' 271 | else buf' |># ", align "# |>$ alignment 272 | {-# INLINABLE renderIR #-} 273 | 274 | renderArithBinOp :: Buffer %1 -> Addr# -> Flag NUW -> Flag NSW -> Operand -> Operand -> Buffer 275 | renderArithBinOp buf opName nuw nsw a b = 276 | (((optional nsw (optional nuw 277 | (buf |># opName) (|># "nuw "#)) (|># "nsw "#) `renderType` typeOf a) |>. ' ') `renderOperand` a |># ", "#) `renderOperand` b 278 | {-# INLINABLE renderArithBinOp #-} 279 | 280 | renderConvertOp :: Buffer %1 -> Addr# -> Operand -> Type -> Buffer 281 | renderConvertOp buf opName val to = 282 | ((((buf |># opName) `renderType` typeOf val) |>. ' ') `renderOperand` val |># " to "#) `renderType` to 283 | {-# INLINABLE renderConvertOp #-} 284 | -------------------------------------------------------------------------------- /lib/LLVM/Codegen/IRBuilder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecursiveDo, PolyKinds, RoleAnnotations #-} 2 | 3 | module LLVM.Codegen.IRBuilder 4 | ( IRBuilderT 5 | , IRBuilder 6 | , block 7 | , blockNamed 8 | , emitBlockStart 9 | , emitInstr 10 | , emitInstrVoid 11 | , emitTerminator 12 | , BasicBlock(..) 13 | , runIRBuilderT 14 | , runIRBuilder 15 | , MonadIRBuilder(..) 16 | 17 | , add 18 | , mul 19 | , sub 20 | , udiv 21 | , and 22 | , or 23 | , trunc 24 | , zext 25 | , ptrtoint 26 | , bitcast 27 | , ptrcast 28 | , icmp 29 | , alloca 30 | , gep 31 | , load 32 | , store 33 | , phi 34 | , call 35 | , ret 36 | , retVoid 37 | , br 38 | , condBr 39 | , switch 40 | , select 41 | 42 | , eq 43 | , ne 44 | , sge 45 | , sgt 46 | , sle 47 | , slt 48 | , uge 49 | , ugt 50 | , ule 51 | , ult 52 | , if' 53 | , loop 54 | , loopWhile 55 | , loopFor 56 | , pointerDiff 57 | , not' 58 | , Signedness(..) 59 | , minimum' 60 | , allocate 61 | , Path(..), (->>), mkPath 62 | , addr, deref, assign, update, increment, copy, swap 63 | 64 | , bit 65 | , int8 66 | , int16 67 | , int32 68 | , int64 69 | , intN 70 | , nullPtr 71 | ) where 72 | 73 | import Prelude hiding (EQ, and, or) 74 | import GHC.Stack 75 | import Control.Monad.Fix 76 | import qualified Data.List.NonEmpty as NE 77 | import Data.List.NonEmpty (NonEmpty(..)) 78 | import Data.Word 79 | import LLVM.Codegen.Name 80 | import LLVM.Codegen.Operand 81 | import LLVM.Codegen.Type 82 | import LLVM.Codegen.IR 83 | import LLVM.Codegen.IRBuilder.Monad 84 | import LLVM.Codegen.ModuleBuilder 85 | 86 | 87 | -- Helpers for generating instructions: 88 | 89 | add :: (MonadIRBuilder m, HasCallStack) => Operand -> Operand -> m Operand 90 | add lhs rhs = 91 | emitInstr (typeOf lhs) $ Add Off Off lhs rhs 92 | {-# INLINEABLE add #-} 93 | 94 | mul :: (MonadIRBuilder m, HasCallStack) => Operand -> Operand -> m Operand 95 | mul lhs rhs = 96 | emitInstr (typeOf lhs) $ Mul Off Off lhs rhs 97 | {-# INLINEABLE mul #-} 98 | 99 | sub :: (MonadIRBuilder m, HasCallStack) => Operand -> Operand -> m Operand 100 | sub lhs rhs = 101 | emitInstr (typeOf lhs) $ Sub Off Off lhs rhs 102 | {-# INLINEABLE sub #-} 103 | 104 | udiv :: (MonadIRBuilder m, HasCallStack) => Operand -> Operand -> m Operand 105 | udiv lhs rhs = 106 | emitInstr (typeOf lhs) $ Udiv Off lhs rhs 107 | {-# INLINEABLE udiv #-} 108 | 109 | and :: (MonadIRBuilder m, HasCallStack) => Operand -> Operand -> m Operand 110 | and lhs rhs = 111 | emitInstr (typeOf lhs) $ And lhs rhs 112 | {-# INLINEABLE and #-} 113 | 114 | or :: (MonadIRBuilder m, HasCallStack) => Operand -> Operand -> m Operand 115 | or lhs rhs = 116 | emitInstr (typeOf lhs) $ Or lhs rhs 117 | {-# INLINEABLE or #-} 118 | 119 | trunc :: (MonadIRBuilder m, HasCallStack) => Operand -> Type -> m Operand 120 | trunc val ty = 121 | emitInstr ty $ Trunc val ty 122 | {-# INLINEABLE trunc #-} 123 | 124 | zext :: (MonadIRBuilder m, HasCallStack) => Operand -> Type -> m Operand 125 | zext val ty = 126 | emitInstr ty $ Zext val ty 127 | {-# INLINEABLE zext #-} 128 | 129 | ptrtoint :: (MonadIRBuilder m, HasCallStack) => Operand -> Type -> m Operand 130 | ptrtoint val ty = 131 | emitInstr ty $ PtrToInt val ty 132 | {-# INLINEABLE ptrtoint #-} 133 | 134 | -- At the moment not useful because of introduction of opaque pointers. 135 | -- Will become more useful once float or vector types are added again. 136 | bitcast :: (MonadIRBuilder m, HasCallStack) => Operand -> Type -> m Operand 137 | bitcast val ty = 138 | emitInstr ty $ Bitcast val ty 139 | {-# INLINEABLE bitcast #-} 140 | 141 | -- Casts a pointer to be a pointer containing type "ty". 142 | -- This helper function is introduced to smooth the transition between 143 | -- LLVM14 -> LLVM15+ (opaque pointer migration). 144 | -- All bitcasts of pointers should be replaced with ptrcasts 145 | ptrcast :: Type -> Operand -> Operand 146 | ptrcast ty = \case 147 | LocalRef (PointerType _) name -> 148 | LocalRef (PointerType ty) name 149 | ConstantOperand (NullPtr _) -> 150 | ConstantOperand $ NullPtr ty 151 | _ -> 152 | error "'ptrcast' is only supported for pointer operands." 153 | {-# INLINEABLE ptrcast #-} 154 | 155 | icmp :: (MonadIRBuilder m, HasCallStack) => ComparisonType -> Operand -> Operand -> m Operand 156 | icmp cmp a b = 157 | emitInstr i1 $ ICmp cmp a b 158 | {-# INLINEABLE icmp #-} 159 | 160 | eq, ne, sge, sgt, sle, slt, uge, ugt, ule, ult 161 | :: (MonadIRBuilder m, HasCallStack) => Operand -> Operand -> m Operand 162 | eq = icmp EQ 163 | ne = icmp NE 164 | sge = icmp SGE 165 | sgt = icmp SGT 166 | sle = icmp SLE 167 | slt = icmp SLT 168 | uge = icmp UGE 169 | ugt = icmp UGT 170 | ule = icmp ULE 171 | ult = icmp ULT 172 | {-# INLINABLE eq #-} 173 | {-# INLINABLE ne #-} 174 | {-# INLINABLE sge #-} 175 | {-# INLINABLE sgt #-} 176 | {-# INLINABLE sle #-} 177 | {-# INLINABLE slt #-} 178 | {-# INLINABLE uge #-} 179 | {-# INLINABLE ugt #-} 180 | {-# INLINABLE ule #-} 181 | {-# INLINABLE ult #-} 182 | 183 | alloca :: (MonadIRBuilder m, HasCallStack) => Type -> Maybe Operand -> Int -> m Operand 184 | alloca ty numElems alignment = 185 | emitInstr (ptr ty) $ Alloca ty numElems alignment 186 | {-# INLINEABLE alloca #-} 187 | 188 | gep :: (HasCallStack, MonadModuleBuilder m, MonadIRBuilder m) 189 | => Operand -> [Operand] -> m Operand 190 | gep operand indices = do 191 | resultType <- computeGepType (typeOf operand) indices 192 | case resultType of 193 | Left err -> error err 194 | Right ty -> 195 | emitInstr ty $ GetElementPtr Off operand indices 196 | {-# INLINEABLE gep #-} 197 | 198 | computeGepType :: (MonadModuleBuilder m, HasCallStack) => Type -> [Operand] -> m (Either String Type) 199 | computeGepType ty [] = pure $ Right $ PointerType ty 200 | computeGepType (PointerType ty) (_ : idxs) = 201 | case (ty, null idxs) of 202 | -- If you want to load something from e.g. i8***, you need to gep + load for each pointer indirection! 203 | (PointerType{}, False) -> pure $ Left "Opaque pointers support only one gep offset." 204 | _ -> computeGepType ty idxs 205 | computeGepType (StructureType _ elTys) (ConstantOperand (Int 32 val):is) = 206 | computeGepType (elTys !! fromIntegral val) is 207 | computeGepType (StructureType _ _) (i:_) = 208 | pure $ Left $ "Indices into structures should be 32-bit integer constants. (Malformed AST): " <> show i 209 | computeGepType (ArrayType _ elTy) (_:is) = computeGepType elTy is 210 | computeGepType (NamedTypeReference n) is = 211 | lookupType n >>= \case 212 | Nothing -> pure $ Left $ "Couldn’t resolve typedef for: " <> show n 213 | Just ty -> computeGepType ty is 214 | computeGepType ty _ = 215 | pure $ Left $ "Expecting aggregate type. (Malformed AST): " <> show ty 216 | {-# INLINEABLE computeGepType #-} 217 | 218 | load :: (HasCallStack, MonadIRBuilder m) => Operand -> Alignment -> m Operand 219 | load address align = 220 | case typeOf address of 221 | PointerType ty -> 222 | emitInstr ty $ Load Off address Nothing align 223 | t -> 224 | error $ "Malformed AST: Expected a pointer type" <> show t 225 | {-# INLINEABLE load #-} 226 | 227 | store :: (MonadIRBuilder m, HasCallStack) => Operand -> Alignment -> Operand -> m () 228 | store address align value = 229 | emitInstrVoid $ Store Off address value Nothing align 230 | {-# INLINEABLE store #-} 231 | 232 | phi :: (HasCallStack, MonadIRBuilder m) => [(Operand, Name)] -> m Operand 233 | phi cases 234 | | null cases = error "phi instruction should always have > 0 cases!" 235 | | otherwise = 236 | let neCases = NE.fromList cases 237 | ty = typeOf $ fst $ NE.head neCases 238 | in emitInstr ty $ Phi neCases 239 | {-# INLINEABLE phi #-} 240 | 241 | call :: (HasCallStack, MonadIRBuilder m) => Operand -> [Operand] -> m Operand 242 | call fn args = case typeOf fn of 243 | FunctionType retTy _-> 244 | emitCallInstr retTy 245 | PointerType (FunctionType retTy _) -> 246 | emitCallInstr retTy 247 | _ -> error "Malformed AST, expected function type in 'call' instruction" 248 | where 249 | emitCallInstr resultTy = 250 | if resultTy == VoidType 251 | then do 252 | emitInstrVoid $ Call Nothing C fn args 253 | pure $ ConstantOperand $ Undef void -- Invalid, but isn't rendered anyway 254 | else emitInstr resultTy $ Call Nothing C fn args 255 | {-# INLINEABLE call #-} 256 | 257 | ret :: (HasCallStack, MonadIRBuilder m) => Operand -> m () 258 | ret val = 259 | emitTerminator (Terminator (Ret (Just val))) 260 | {-# INLINEABLE ret #-} 261 | 262 | retVoid :: (HasCallStack, MonadIRBuilder m) => m () 263 | retVoid = 264 | emitTerminator (Terminator (Ret Nothing)) 265 | {-# INLINEABLE retVoid #-} 266 | 267 | br :: (MonadIRBuilder m, HasCallStack) => Name -> m () 268 | br label = 269 | emitTerminator (Terminator (Br label)) 270 | {-# INLINEABLE br #-} 271 | 272 | condBr :: (HasCallStack, MonadIRBuilder m) => Operand -> Name -> Name -> m () 273 | condBr cond trueLabel falseLabel = 274 | emitTerminator (Terminator (CondBr cond trueLabel falseLabel)) 275 | {-# INLINEABLE condBr #-} 276 | 277 | switch :: (HasCallStack, MonadIRBuilder m) => Operand -> Name -> [(Operand, Name)] -> m () 278 | switch value defaultDest dests = 279 | emitTerminator $ Terminator $ Switch value defaultDest dests 280 | {-# INLINEABLE switch #-} 281 | 282 | select :: (HasCallStack, MonadIRBuilder m) => Operand -> Operand -> Operand -> m Operand 283 | select c t f = 284 | emitInstr (typeOf t) $ Select c t f 285 | {-# INLINEABLE select #-} 286 | 287 | if' :: (HasCallStack, MonadIRBuilder m, MonadFix m) 288 | => Operand -> m a -> m () 289 | if' condition asm = mdo 290 | condBr condition ifBlock end 291 | ifBlock <- blockNamed "if" 292 | _ <- asm 293 | br end 294 | end <- blockNamed "end_if" 295 | pure () 296 | {-# INLINEABLE if' #-} 297 | 298 | loop :: (HasCallStack, MonadIRBuilder m, MonadFix m) => m a -> m () 299 | loop asm = mdo 300 | br begin 301 | begin <- blockNamed "loop" 302 | _ <- asm 303 | br begin 304 | {-# INLINEABLE loop #-} 305 | 306 | loopWhile :: (HasCallStack, MonadIRBuilder m, MonadFix m) 307 | => m Operand -> m a -> m () 308 | loopWhile condition asm = mdo 309 | br begin 310 | begin <- blockNamed "while_begin" 311 | result <- condition 312 | condBr result body end 313 | body <- blockNamed "while_body" 314 | _ <- asm 315 | br begin 316 | end <- blockNamed "while_end" 317 | pure () 318 | {-# INLINEABLE loopWhile #-} 319 | 320 | loopFor :: (HasCallStack, MonadModuleBuilder m, MonadIRBuilder m, MonadFix m) 321 | => Operand 322 | -> (Operand -> m Operand) 323 | -> (Operand -> m Operand) 324 | -> (Operand -> m a) 325 | -> m () 326 | loopFor beginValue condition post asm = mdo 327 | start <- currentBlock 328 | br begin 329 | begin <- blockNamed "for_begin" 330 | loopValue <- phi [(beginValue, start), (updatedValue, bodyEnd)] 331 | result <- condition loopValue 332 | condBr result bodyStart end 333 | bodyStart <- blockNamed "for_body" 334 | _ <- asm loopValue 335 | updatedValue <- post loopValue 336 | bodyEnd <- currentBlock 337 | br begin 338 | end <- blockNamed "for_end" 339 | pure () 340 | {-# INLINEABLE loopFor #-} 341 | 342 | -- NOTE: diff is in bytes! (Different compared to C and C++) 343 | pointerDiff :: (HasCallStack, MonadIRBuilder m) 344 | => Type -> Operand -> Operand -> m Operand 345 | pointerDiff ty a b = do 346 | a' <- ptrtoint a i64 347 | b' <- ptrtoint b i64 348 | result <- sub a' b' 349 | if ty == i64 350 | then pure result 351 | else trunc result ty 352 | {-# INLINEABLE pointerDiff #-} 353 | 354 | -- | Calculates the logical not of a boolean 'Operand'. 355 | -- NOTE: This assumes the 'Operand' is of type 'i1', this is not checked! 356 | -- Passing in an argument of another width will lead to a crash in LLVM. 357 | not' :: (HasCallStack, MonadIRBuilder m) 358 | => Operand -> m Operand 359 | not' bool = 360 | select bool (bit 0) (bit 1) 361 | {-# INLINEABLE not' #-} 362 | 363 | data Signedness = Signed | Unsigned 364 | 365 | -- NOTE: No check is made if the 2 operands have the same 'Type'! 366 | minimum' :: (HasCallStack, MonadIRBuilder m) 367 | => Signedness -> Operand -> Operand -> m Operand 368 | minimum' sign a b = do 369 | let inst = case sign of 370 | Signed -> slt 371 | Unsigned -> ult 372 | isLessThan <- inst a b 373 | select isLessThan a b 374 | {-# INLINEABLE minimum' #-} 375 | 376 | allocate :: (HasCallStack, MonadIRBuilder m) => Type -> Operand -> m Operand 377 | allocate ty beginValue = do 378 | value <- alloca ty Nothing 0 379 | store value 0 beginValue 380 | pure value 381 | {-# INLINEABLE allocate #-} 382 | 383 | newtype Path (a :: k) (b :: k) 384 | = Path (NonEmpty Operand) 385 | deriving (Eq, Show) 386 | type role Path nominal nominal 387 | 388 | mkPath :: [Operand] -> Path a b 389 | mkPath path = Path (int32 0 :| path) 390 | 391 | (->>) :: Path a b -> Path b c -> Path a c 392 | Path a2b ->> Path b2c = 393 | let b2c' = if NE.head b2c == int32 0 394 | then NE.tail b2c 395 | else NE.toList b2c 396 | in Path $ NE.head a2b :| (NE.tail a2b ++ b2c') 397 | 398 | addr :: (MonadModuleBuilder m, MonadIRBuilder m, HasCallStack) 399 | => Path a b -> Operand -> m Operand 400 | addr path p = gep p (pathToIndices path) 401 | where 402 | pathToIndices :: Path a b -> [Operand] 403 | pathToIndices (Path indices) = 404 | NE.toList indices 405 | {-# INLINEABLE addr #-} 406 | 407 | deref :: (MonadModuleBuilder m, MonadIRBuilder m, HasCallStack) 408 | => Path a b -> Operand -> m Operand 409 | deref path p = do 410 | address <- addr path p 411 | load address 0 412 | {-# INLINEABLE deref #-} 413 | 414 | assign :: (MonadModuleBuilder m, MonadIRBuilder m, HasCallStack) 415 | => Path a b -> Operand -> Operand -> m () 416 | assign path p value = do 417 | dstAddr <- addr path p 418 | store dstAddr 0 value 419 | {-# INLINEABLE assign #-} 420 | 421 | update :: (MonadModuleBuilder m, MonadIRBuilder m, HasCallStack) 422 | => Path a b 423 | -> Operand 424 | -> (Operand -> m Operand) 425 | -> m () 426 | update path p f = do 427 | dstAddr <- addr path p 428 | store dstAddr 0 =<< f =<< load dstAddr 0 429 | {-# INLINEABLE update #-} 430 | 431 | increment :: (MonadModuleBuilder m, MonadIRBuilder m, HasCallStack) 432 | => (Integer -> Operand) -> Path a b -> Operand -> m () 433 | increment ty path p = 434 | update path p (add (ty 1)) 435 | {-# INLINEABLE increment #-} 436 | 437 | copy :: (MonadModuleBuilder m, MonadIRBuilder m, HasCallStack) 438 | => Path a b -> Operand -> Operand -> m () 439 | copy path src dst = do 440 | value <- deref path src 441 | assign path dst value 442 | {-# INLINEABLE copy #-} 443 | 444 | swap :: (MonadModuleBuilder m, MonadIRBuilder m, HasCallStack) 445 | => Path a b -> Operand -> Operand -> m () 446 | swap path lhs rhs = do 447 | tmp <- deref path lhs 448 | copy path rhs lhs 449 | assign path rhs tmp 450 | {-# INLINEABLE swap #-} 451 | 452 | 453 | bit :: Integer -> Operand 454 | bit b = 455 | intN 1 $ if b == 0 then 0 else 1 456 | 457 | int8 :: Integer -> Operand 458 | int8 = 459 | intN 8 460 | 461 | int16 :: Integer -> Operand 462 | int16 = 463 | intN 16 464 | 465 | int32 :: Integer -> Operand 466 | int32 = 467 | intN 32 468 | 469 | int64 :: Integer -> Operand 470 | int64 = 471 | intN 64 472 | 473 | intN :: Word32 -> Integer -> Operand 474 | intN bits value = 475 | ConstantOperand $ Int bits value 476 | 477 | nullPtr :: Type -> Operand 478 | nullPtr = 479 | ConstantOperand . NullPtr 480 | -------------------------------------------------------------------------------- /lib/LLVM/Codegen/IRBuilder/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, RankNTypes, MultiParamTypeClasses, UndecidableInstances, BangPatterns, TypeOperators #-} 2 | 3 | module LLVM.Codegen.IRBuilder.Monad 4 | ( IRBuilderT 5 | , IRBuilder 6 | , runIRBuilderT 7 | , runIRBuilder 8 | , MonadIRBuilder(..) 9 | , BasicBlock(..) 10 | , block 11 | , blockNamed 12 | , emitBlockStart 13 | , emitInstr 14 | , emitInstrVoid 15 | , emitTerminator 16 | , renderBasicBlock 17 | , freshName 18 | ) where 19 | 20 | -- NOTE: this module only exists to solve a cyclic import 21 | 22 | import Prelude hiding (and) 23 | import Control.Arrow hiding ((<+>)) 24 | import Control.Monad.State.Lazy (StateT(..), MonadState, modify) 25 | import qualified Control.Monad.State.Strict as StrictState 26 | import qualified Control.Monad.State.Lazy as LazyState 27 | import qualified Control.Monad.RWS.Lazy as LazyRWS 28 | import qualified Control.Monad.RWS.Strict as StrictRWS 29 | import Control.Monad 30 | import Control.Monad.Reader 31 | import Control.Monad.Writer 32 | import Control.Monad.Except 33 | import Control.Monad.Morph 34 | import Control.Monad.Fix 35 | import Data.Functor.Identity 36 | import qualified Data.Text as T 37 | import qualified Data.DList as DList 38 | import Data.DList (DList) 39 | import qualified Data.Map as M 40 | import Data.Map (Map) 41 | import Data.Maybe 42 | import Data.Monoid 43 | import LLVM.Codegen.Operand 44 | import LLVM.Codegen.IR 45 | import LLVM.Codegen.Type 46 | import LLVM.Codegen.Name 47 | import LLVM.Pretty 48 | 49 | 50 | data BasicBlock 51 | = BB 52 | { bbName :: !Name 53 | , bbInstructions :: !(DList (Maybe Operand, IR)) 54 | , bbTerminator :: !Terminator 55 | } deriving Show 56 | 57 | data PartialBlock 58 | = PartialBlock 59 | { pbName :: !Name 60 | , pbInstructions :: !(DList (Maybe Operand, IR)) 61 | , pbTerminator :: !(First Terminator) 62 | , pbNumInstrs :: !Int 63 | } 64 | 65 | data IRBuilderState 66 | = IRBuilderState 67 | { allocas :: !(DList (Maybe Operand, IR)) 68 | , basicBlocks :: !(DList BasicBlock) 69 | , currentPartialBlock :: !PartialBlock 70 | , operandCounter :: !Int 71 | , nameMap :: !(Map T.Text Int) 72 | } 73 | 74 | newtype IRBuilderT m a 75 | = IRBuilderT { unIRBuilderT :: StateT IRBuilderState m a } 76 | deriving ( Functor, Applicative, Monad, MonadFix, MonadIO 77 | , MonadError e 78 | ) 79 | via StateT IRBuilderState m 80 | 81 | instance MonadReader r m => MonadReader r (IRBuilderT m) where 82 | ask = lift ask 83 | {-# INLINEABLE ask #-} 84 | local = mapIRBuilderT . local 85 | {-# INLINEABLE local #-} 86 | 87 | -- TODO MonadWriter 88 | 89 | mapIRBuilderT :: (Monad m, Monad n) => (m a -> n a) -> IRBuilderT m a -> IRBuilderT n a 90 | mapIRBuilderT f (IRBuilderT inner) = 91 | IRBuilderT $ do 92 | s <- LazyState.get 93 | LazyState.mapStateT (g s) inner 94 | where 95 | g s = fmap (,s) . f . fmap fst 96 | {-# INLINEABLE mapIRBuilderT #-} 97 | 98 | instance MonadState s m => MonadState s (IRBuilderT m) where 99 | state = lift . StrictState.state 100 | {-# INLINEABLE state #-} 101 | 102 | instance MonadTrans IRBuilderT where 103 | lift = IRBuilderT . lift 104 | {-# INLINEABLE lift #-} 105 | 106 | instance MFunctor IRBuilderT where 107 | hoist nat = IRBuilderT . hoist nat . unIRBuilderT 108 | {-# INLINEABLE hoist #-} 109 | 110 | type IRBuilder = IRBuilderT Identity 111 | 112 | runIRBuilderT :: Monad m => IRBuilderT m a -> m (a, [BasicBlock]) 113 | runIRBuilderT (IRBuilderT m) = do 114 | let partialBlock = PartialBlock (Name "start") mempty mempty 0 115 | result = runStateT m (IRBuilderState mempty mempty partialBlock 0 mempty) 116 | fmap (second getBlocks) result 117 | where 118 | getBlocks irState = 119 | case blocks of 120 | [] -> [] 121 | (firstBlk:restBlks) -> 122 | let firstBlk' = firstBlk { bbInstructions = DList.append allocations (bbInstructions firstBlk) } 123 | in (firstBlk':restBlks) 124 | where 125 | previousBlocks = DList.apply (basicBlocks irState) mempty 126 | currentBlk = currentPartialBlock irState 127 | blocks = previousBlocks <> [partialBlockToBasicBlock currentBlk] 128 | allocations = allocas irState 129 | {-# INLINEABLE runIRBuilderT #-} 130 | 131 | runIRBuilder :: IRBuilder a -> (a, [BasicBlock]) 132 | runIRBuilder = runIdentity . runIRBuilderT 133 | {-# INLINEABLE runIRBuilder #-} 134 | 135 | partialBlockToBasicBlock :: PartialBlock -> BasicBlock 136 | partialBlockToBasicBlock pb = 137 | let currentTerm = fromMaybe (Terminator $ Ret Nothing) $ getFirst $ pbTerminator pb 138 | in BB (pbName pb) (pbInstructions pb) currentTerm 139 | {-# INLINEABLE partialBlockToBasicBlock #-} 140 | 141 | block :: (MonadIRBuilder m) => m Name 142 | block = do 143 | blockName <- freshName (Just "block") 144 | emitBlockStart blockName 145 | pure blockName 146 | {-# INLINEABLE block #-} 147 | 148 | blockNamed :: (MonadIRBuilder m) => T.Text -> m Name 149 | blockNamed blkName = do 150 | blockName <- freshName (Just blkName) 151 | emitBlockStart blockName 152 | pure blockName 153 | {-# INLINEABLE blockNamed #-} 154 | 155 | emitBlockStart :: (MonadIRBuilder m) => Name -> m () 156 | emitBlockStart blockName = 157 | modifyIRBuilderState $ \s -> 158 | let currBlock = currentPartialBlock s 159 | hasntStartedBlock = (pbNumInstrs currBlock == 0) && isNothing (getFirst (pbTerminator currBlock)) 160 | blocks = basicBlocks s 161 | -- If the current block is empty: 162 | -- Insert a dummy basic block that jumps directly to the next block, to avoid continuity errors. 163 | -- Normally, LLVM should optimize this away since it is semantically a no-op. 164 | -- Otherwise: 165 | -- Append the current block to the existing list of blocks. 166 | -- 167 | -- NOTE: This is different behavior compared to the llvm-hs-pure library, 168 | -- but this avoids a lot of partial functions! 169 | newBlock = 170 | if hasntStartedBlock 171 | then BB (pbName currBlock) mempty (Terminator $ Br blockName) 172 | else partialBlockToBasicBlock currBlock 173 | in s { basicBlocks = DList.snoc blocks newBlock 174 | , currentPartialBlock = PartialBlock blockName mempty mempty 0 175 | } 176 | {-# INLINEABLE emitBlockStart #-} 177 | 178 | -- NOTE: Only used internally, this creates an unassigned operand 179 | mkOperand :: (MonadIRBuilder m) => Type -> m Operand 180 | mkOperand ty = LocalRef ty <$!> freshUnnamed 181 | {-# INLINEABLE mkOperand #-} 182 | 183 | freshName :: MonadIRBuilder m => Maybe T.Text -> m Name 184 | freshName = \case 185 | Nothing -> freshUnnamed 186 | Just suggestion -> do 187 | nameMapping <- nameMap <$> getIRBuilderState 188 | let !mCount = M.lookup suggestion nameMapping 189 | !count = fromMaybe 0 mCount 190 | !newMapping = M.insert suggestion (count + 1) nameMapping 191 | modifyIRBuilderState $ \s -> s { nameMap = newMapping } 192 | pure $! Name $! suggestion <> "_" <> T.pack (show count) 193 | {-# INLINEABLE freshName #-} 194 | 195 | freshUnnamed :: MonadIRBuilder m => m Name 196 | freshUnnamed = do 197 | !ctr <- operandCounter <$> getIRBuilderState 198 | let !newCount = ctr + 1 199 | modifyIRBuilderState $ \s -> s { operandCounter = newCount } 200 | pure $! Generated ctr 201 | {-# INLINEABLE freshUnnamed #-} 202 | 203 | emitInstr :: (MonadIRBuilder m) => Type -> IR -> m Operand 204 | emitInstr ty = \case 205 | instr@(Alloca {}) -> do 206 | -- For performant code, all alloca instructions should be at the start of the function! 207 | -- https://llvm.org/docs/Frontend/PerformanceTips.html#use-of-allocas 208 | -- (A custom operand name is only used here to avoid having to re-number all operands.) 209 | operand <- LocalRef ty <$!> freshName (Just "stack.ptr") 210 | addAlloca operand instr 211 | pure operand 212 | instr -> do 213 | operand <- mkOperand ty 214 | addInstrToCurrentBlock (Just operand) instr 215 | pure operand 216 | {-# INLINABLE emitInstr #-} 217 | 218 | emitInstrVoid :: MonadIRBuilder m => IR -> m () 219 | emitInstrVoid = 220 | addInstrToCurrentBlock Nothing 221 | {-# INLINABLE emitInstrVoid #-} 222 | 223 | addInstrToCurrentBlock :: MonadIRBuilder m => Maybe Operand -> IR -> m () 224 | addInstrToCurrentBlock operand instr = 225 | modifyCurrentBlock $ \blk -> 226 | let instrs = DList.snoc (pbInstructions blk) (operand, instr) 227 | in blk { pbInstructions = instrs, pbNumInstrs = pbNumInstrs blk + 1 } 228 | {-# INLINEABLE addInstrToCurrentBlock #-} 229 | 230 | addAlloca :: MonadIRBuilder m => Operand -> IR -> m () 231 | addAlloca operand instr = 232 | modifyIRBuilderState $ \s -> 233 | s { allocas = DList.snoc (allocas s) (Just operand, instr) } 234 | {-# INLINEABLE addAlloca #-} 235 | 236 | emitTerminator :: MonadIRBuilder m => Terminator -> m () 237 | emitTerminator term = 238 | modifyCurrentBlock $ \blk -> 239 | blk { pbTerminator = pbTerminator blk <> First (Just term) } 240 | {-# INLINABLE emitTerminator #-} 241 | 242 | modifyCurrentBlock :: MonadIRBuilder m => (PartialBlock -> PartialBlock) -> m () 243 | modifyCurrentBlock f = 244 | modifyIRBuilderState $ \s -> 245 | s { currentPartialBlock = f (currentPartialBlock s) } 246 | {-# INLINEABLE modifyCurrentBlock #-} 247 | 248 | class Monad m => MonadIRBuilder m where 249 | getIRBuilderState :: m IRBuilderState 250 | 251 | modifyIRBuilderState :: (IRBuilderState -> IRBuilderState) -> m () 252 | 253 | currentBlock :: m Name 254 | 255 | default getIRBuilderState 256 | :: (MonadTrans t, MonadIRBuilder m1, m ~ t m1) 257 | => m IRBuilderState 258 | getIRBuilderState = lift getIRBuilderState 259 | {-# INLINEABLE getIRBuilderState #-} 260 | 261 | default modifyIRBuilderState 262 | :: (MonadTrans t, MonadIRBuilder m1, m ~ t m1) 263 | => (IRBuilderState -> IRBuilderState) 264 | -> m () 265 | modifyIRBuilderState = lift . modifyIRBuilderState 266 | {-# INLINEABLE modifyIRBuilderState #-} 267 | 268 | default currentBlock 269 | :: (MonadTrans t, MonadIRBuilder m1, m ~ t m1) 270 | => m Name 271 | currentBlock = lift currentBlock 272 | {-# INLINEABLE currentBlock #-} 273 | 274 | instance Monad m => MonadIRBuilder (IRBuilderT m) where 275 | getIRBuilderState = IRBuilderT LazyState.get 276 | {-# INLINEABLE getIRBuilderState #-} 277 | 278 | modifyIRBuilderState = IRBuilderT . modify 279 | {-# INLINEABLE modifyIRBuilderState #-} 280 | 281 | currentBlock = 282 | IRBuilderT $ LazyState.gets (pbName . currentPartialBlock) 283 | {-# INLINEABLE currentBlock #-} 284 | 285 | instance MonadIRBuilder m => MonadIRBuilder (StrictState.StateT s m) 286 | instance MonadIRBuilder m => MonadIRBuilder (LazyState.StateT s m) 287 | instance (MonadIRBuilder m, Monoid w) => MonadIRBuilder (StrictRWS.RWST r w s m) 288 | instance (MonadIRBuilder m, Monoid w) => MonadIRBuilder (LazyRWS.RWST r w s m) 289 | instance MonadIRBuilder m => MonadIRBuilder (ReaderT r m) 290 | instance (MonadIRBuilder m, Monoid w) => MonadIRBuilder (WriterT w m) 291 | instance MonadIRBuilder m => MonadIRBuilder (ExceptT e m) 292 | 293 | renderBasicBlock :: Renderer BasicBlock 294 | renderBasicBlock buf (BB name stmts (Terminator term)) = 295 | if null stmts 296 | then (renderName buf name |># ":\n "#) `renderIR` term 297 | else (vsep (renderName buf name |># ":\n"#) stmts' renderStmt |># "\n "#) `renderIR` term 298 | where 299 | stmts' = DList.apply stmts [] 300 | renderStmt :: Buffer %1 -> (Maybe Operand, IR) -> Buffer 301 | renderStmt buf' (mOperand, instr) = 302 | withIndent buf' (\buf'' -> renderStmt' buf'' mOperand instr) 303 | renderStmt' :: Buffer %1 -> Maybe Operand -> IR -> Buffer 304 | renderStmt' buf' mOperand instr = 305 | renderMaybe buf' mOperand (\buf'' operand -> buf'' `renderOperand` operand |># " = "#) `renderIR` instr 306 | {-# INLINABLE renderBasicBlock #-} 307 | -------------------------------------------------------------------------------- /lib/LLVM/Codegen/ModuleBuilder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, MultiParamTypeClasses, UndecidableInstances, TypeOperators #-} 2 | 3 | module LLVM.Codegen.ModuleBuilder 4 | ( ModuleBuilderT 5 | , ModuleBuilder 6 | , runModuleBuilderT 7 | , runModuleBuilder 8 | , MonadModuleBuilder 9 | , Module(..) 10 | , Definition(..) 11 | , ParameterName(..) 12 | , FunctionAttribute(..) 13 | , function 14 | , global 15 | , globalUtf8StringPtr 16 | , extern 17 | , typedef 18 | , opaqueTypedef 19 | , getTypedefs 20 | , lookupType 21 | , withFunctionAttributes 22 | , renderModule 23 | ) where 24 | 25 | import GHC.Stack 26 | import Control.Monad.State.Lazy (StateT(..), MonadState, State, execStateT, modify, gets) 27 | import qualified Control.Monad.State.Strict as StrictState 28 | import qualified Control.Monad.State.Lazy as LazyState 29 | import qualified Control.Monad.RWS.Lazy as LazyRWS 30 | import qualified Control.Monad.RWS.Strict as StrictRWS 31 | import Control.Monad.Reader 32 | import Control.Monad.Writer 33 | import Control.Monad.Except 34 | import Control.Monad.Morph 35 | import Control.Monad.Fix 36 | import Data.DList (DList) 37 | import Data.Map (Map) 38 | import Data.String 39 | import qualified Data.DList as DList 40 | import qualified Data.Map as Map 41 | import qualified Data.Text as T 42 | import qualified Data.Text.Encoding as TE 43 | import qualified Data.ByteString as BS 44 | import Data.Functor.Identity 45 | import LLVM.Codegen.IRBuilder.Monad 46 | import LLVM.Codegen.Operand 47 | import LLVM.Codegen.Type 48 | import LLVM.Codegen.Name 49 | import LLVM.Codegen.Flag 50 | import LLVM.Codegen.IR 51 | import LLVM.Pretty 52 | 53 | 54 | newtype Module 55 | = Module [Definition] 56 | 57 | data ParameterName 58 | = ParameterName !T.Text 59 | | NoParameterName 60 | deriving Show 61 | 62 | instance IsString ParameterName where 63 | fromString = ParameterName . fromString 64 | 65 | data FunctionAttribute 66 | = WasmExportName !T.Text 67 | | AlwaysInline 68 | -- Add more as needed.. 69 | deriving Show 70 | 71 | data Global 72 | = GlobalVariable !Name !Type !Constant 73 | | Function !Name !Type ![(Type, ParameterName)] ![FunctionAttribute] ![BasicBlock] 74 | deriving Show 75 | 76 | data Typedef 77 | = Opaque 78 | | Clear !Type 79 | deriving Show 80 | 81 | data Definition 82 | = GlobalDefinition !Global 83 | | TypeDefinition !Name !Typedef 84 | deriving Show 85 | 86 | data ModuleBuilderState 87 | = ModuleBuilderState 88 | { definitions :: !(DList Definition) 89 | , types :: !(Map Name Type) 90 | , defaultFunctionAttributes :: ![FunctionAttribute] 91 | } 92 | 93 | newtype ModuleBuilderT m a 94 | = ModuleBuilderT { unModuleBuilderT :: StateT ModuleBuilderState m a } 95 | deriving ( Functor, Applicative, Monad, MonadFix, MonadIO 96 | , MonadError e 97 | ) 98 | via StateT ModuleBuilderState m 99 | 100 | type ModuleBuilder = ModuleBuilderT Identity 101 | 102 | instance MonadTrans ModuleBuilderT where 103 | lift = ModuleBuilderT . lift 104 | {-# INLINEABLE lift #-} 105 | 106 | instance MonadReader r m => MonadReader r (ModuleBuilderT m) where 107 | ask = lift ask 108 | {-# INLINEABLE ask #-} 109 | local = mapModuleBuilderT . local 110 | {-# INLINEABLE local #-} 111 | 112 | mapModuleBuilderT :: (Functor m, Monad n) => (m a -> n a) -> ModuleBuilderT m a -> ModuleBuilderT n a 113 | mapModuleBuilderT f (ModuleBuilderT inner) = 114 | ModuleBuilderT $ do 115 | s <- LazyState.get 116 | LazyState.mapStateT (g s) inner 117 | where 118 | g s = fmap (,s) . f . fmap fst 119 | {-# INLINEABLE mapModuleBuilderT #-} 120 | 121 | instance MonadState s m => MonadState s (ModuleBuilderT m) where 122 | state = lift . LazyState.state 123 | {-# INLINEABLE state #-} 124 | 125 | instance MFunctor ModuleBuilderT where 126 | hoist nat = ModuleBuilderT . hoist nat . unModuleBuilderT 127 | {-# INLINEABLE hoist #-} 128 | 129 | class Monad m => MonadModuleBuilder m where 130 | liftModuleBuilderState :: State ModuleBuilderState a -> m a 131 | 132 | default liftModuleBuilderState 133 | :: (MonadTrans t, MonadModuleBuilder m1, m ~ t m1) 134 | => State ModuleBuilderState a 135 | -> m a 136 | liftModuleBuilderState = lift . liftModuleBuilderState 137 | {-# INLINEABLE liftModuleBuilderState #-} 138 | 139 | instance Monad m => MonadModuleBuilder (ModuleBuilderT m) where 140 | liftModuleBuilderState (StateT s) = 141 | ModuleBuilderT $ StateT $ pure . runIdentity . s 142 | {-# INLINEABLE liftModuleBuilderState #-} 143 | 144 | instance MonadModuleBuilder m => MonadModuleBuilder (IRBuilderT m) 145 | instance MonadModuleBuilder m => MonadModuleBuilder (StrictState.StateT s m) 146 | instance MonadModuleBuilder m => MonadModuleBuilder (LazyState.StateT s m) 147 | instance (MonadModuleBuilder m, Monoid w) => MonadModuleBuilder (StrictRWS.RWST r w s m) 148 | instance (MonadModuleBuilder m, Monoid w) => MonadModuleBuilder (LazyRWS.RWST r w s m) 149 | instance MonadModuleBuilder m => MonadModuleBuilder (ReaderT r m) 150 | instance (MonadModuleBuilder m, Monoid w) => MonadModuleBuilder (WriterT w m) 151 | instance MonadModuleBuilder m => MonadModuleBuilder (ExceptT e m) 152 | 153 | runModuleBuilderT :: Monad m => ModuleBuilderT m a -> m Module 154 | runModuleBuilderT (ModuleBuilderT m) = 155 | Module . DList.toList . definitions <$> execStateT m beginState 156 | where 157 | beginState = ModuleBuilderState mempty mempty [] 158 | {-# INLINEABLE runModuleBuilderT #-} 159 | 160 | withFunctionAttributes 161 | :: MonadModuleBuilder m 162 | => ([FunctionAttribute] -> [FunctionAttribute]) 163 | -> m a -> m a 164 | withFunctionAttributes f m = do 165 | fnAttrs <- liftModuleBuilderState (gets defaultFunctionAttributes) 166 | liftModuleBuilderState $ 167 | modify $ \s -> s { defaultFunctionAttributes = f fnAttrs } 168 | result <- m 169 | liftModuleBuilderState $ 170 | modify $ \s -> s { defaultFunctionAttributes = fnAttrs } 171 | pure result 172 | {-# INLINEABLE withFunctionAttributes #-} 173 | 174 | resetFunctionAttributes :: MonadModuleBuilder m => m () 175 | resetFunctionAttributes = 176 | liftModuleBuilderState $ 177 | modify $ \s -> s { defaultFunctionAttributes = mempty } 178 | {-# INLINEABLE resetFunctionAttributes #-} 179 | 180 | getDefaultFunctionAttributes :: MonadModuleBuilder m => m [FunctionAttribute] 181 | getDefaultFunctionAttributes = 182 | liftModuleBuilderState $ gets defaultFunctionAttributes 183 | {-# INLINEABLE getDefaultFunctionAttributes #-} 184 | 185 | runModuleBuilder :: ModuleBuilder a -> Module 186 | runModuleBuilder = runIdentity . runModuleBuilderT 187 | {-# INLINEABLE runModuleBuilder #-} 188 | 189 | function :: (HasCallStack, MonadModuleBuilder m) 190 | => Name -> [(Type, ParameterName)] -> Type -> ([Operand] -> IRBuilderT m a) -> m Operand 191 | function name args retTy fnBody = do 192 | fnAttrs <- getDefaultFunctionAttributes 193 | 194 | (names, instrs) <- runIRBuilderT $ do 195 | (names, operands) <- unzip <$> traverse (uncurry mkOperand) args 196 | resetFunctionAttributes -- This is done to avoid functions emitted in the body that not automatically copy the same attributes 197 | _ <- fnBody operands 198 | pure names 199 | 200 | liftModuleBuilderState $ 201 | modify $ \s -> s { defaultFunctionAttributes = fnAttrs } 202 | let args' = zipWith (\argName (ty, _) -> (ty, ParameterName $ unName argName)) names args 203 | emitDefinition $ GlobalDefinition $ Function name retTy args' fnAttrs instrs 204 | pure $ ConstantOperand $ GlobalRef (ptr (FunctionType retTy $ map fst args)) name 205 | {-# INLINEABLE function #-} 206 | 207 | emitDefinition :: MonadModuleBuilder m => Definition -> m () 208 | emitDefinition def = 209 | liftModuleBuilderState $ modify $ \s -> s { definitions = DList.snoc (definitions s) def } 210 | {-# INLINEABLE emitDefinition #-} 211 | 212 | getTypedefs :: MonadModuleBuilder m => m (Map Name Type) 213 | getTypedefs = 214 | liftModuleBuilderState $ gets types 215 | {-# INLINEABLE getTypedefs #-} 216 | 217 | lookupType :: MonadModuleBuilder m => Name -> m (Maybe Type) 218 | lookupType name = 219 | liftModuleBuilderState $ gets (Map.lookup name . types) 220 | {-# INLINEABLE lookupType #-} 221 | 222 | addType :: MonadModuleBuilder m => Name -> Type -> m () 223 | addType name ty = 224 | liftModuleBuilderState $ modify $ \s -> s { types = Map.insert name ty (types s) } 225 | {-# INLINEABLE addType #-} 226 | 227 | global :: MonadModuleBuilder m => Name -> Type -> Constant -> m Operand 228 | global name ty constant = do 229 | emitDefinition $ GlobalDefinition $ GlobalVariable name ty constant 230 | pure $ ConstantOperand $ GlobalRef (ptr ty) name 231 | {-# INLINEABLE global #-} 232 | 233 | globalUtf8StringPtr :: (HasCallStack, MonadModuleBuilder m, MonadIRBuilder m) 234 | => T.Text -> Name -> m Operand 235 | globalUtf8StringPtr txt name = do 236 | let utf8Bytes = BS.snoc (TE.encodeUtf8 txt) 0 -- 0-terminated UTF8 string 237 | llvmValues = map (Int 8 . toInteger) $ BS.unpack utf8Bytes 238 | arrayValue = Array i8 llvmValues 239 | constant = ConstantOperand arrayValue 240 | ty = typeOf constant 241 | -- This definition will end up before the function this is used in 242 | addr <- global name ty arrayValue 243 | let instr = GetElementPtr On addr [ ConstantOperand $ Int 32 0 244 | , ConstantOperand $ Int 32 0 245 | ] 246 | emitInstr (ptr i8) instr 247 | {-# INLINEABLE globalUtf8StringPtr #-} 248 | 249 | -- NOTE: typedefs are only allowed for structs, even though clang also allows it 250 | -- for primitive types. This is done to avoid weird inconsistencies with the LLVM JIT 251 | -- (where this is not allowed). 252 | typedef :: MonadModuleBuilder m => Name -> Flag Packed -> [Type] -> m Type 253 | typedef name packed tys = do 254 | let ty = StructureType packed tys 255 | emitDefinition $ TypeDefinition name (Clear ty) 256 | addType name ty 257 | pure $ NamedTypeReference name 258 | {-# INLINEABLE typedef #-} 259 | 260 | opaqueTypedef :: MonadModuleBuilder m => Name -> m Type 261 | opaqueTypedef name = do 262 | emitDefinition $ TypeDefinition name Opaque 263 | pure $ NamedTypeReference name 264 | {-# INLINEABLE opaqueTypedef #-} 265 | 266 | extern :: MonadModuleBuilder m => Name -> [Type] -> Type -> m Operand 267 | extern name argTys retTy = do 268 | let args = [(argTy, ParameterName "") | argTy <- argTys] 269 | fnAttrs <- getDefaultFunctionAttributes 270 | emitDefinition $ GlobalDefinition $ Function name retTy args fnAttrs [] 271 | let fnTy = ptr $ FunctionType retTy argTys 272 | pure $ ConstantOperand $ GlobalRef fnTy name 273 | {-# INLINEABLE extern #-} 274 | 275 | -- NOTE: Only used internally, this creates an unassigned operand 276 | mkOperand :: Monad m => Type -> ParameterName -> IRBuilderT m (Name, Operand) 277 | mkOperand ty paramName = do 278 | name <- case paramName of 279 | NoParameterName -> freshName Nothing 280 | ParameterName name -> freshName (Just name) 281 | pure (name, LocalRef ty name) 282 | {-# INLINEABLE mkOperand #-} 283 | 284 | renderModule :: Renderer Module 285 | renderModule buf (Module defs) = 286 | sepBy "\n\n"# buf defs renderDefinition 287 | {-# INLINEABLE renderModule #-} 288 | 289 | renderDefinition :: Renderer Definition 290 | renderDefinition buf = \case 291 | GlobalDefinition g -> 292 | renderGlobal buf g 293 | TypeDefinition name typeDef -> 294 | case typeDef of 295 | Opaque -> 296 | (buf |>. '%') `renderName` name |># " = type opaque"# 297 | Clear ty -> 298 | ((buf |>. '%') `renderName` name |># " = type "#) `renderType` ty 299 | {-# INLINEABLE renderDefinition #-} 300 | 301 | renderGlobal :: Renderer Global 302 | renderGlobal buf = \case 303 | GlobalVariable name ty constant -> 304 | (((((buf |>. '@') `renderName` name) |># " = global "#) `renderType` ty) |>. ' ') `renderConstant` constant 305 | Function name retTy args attrs body 306 | | null body -> 307 | hsep (tupled ((((buf |># "declare external ccc "#) `renderType` retTy) |># " @"#) `renderName` name) argTys renderType 308 | |># (if null attrs then ""# else " "#)) attrs renderFunctionAttr 309 | | otherwise -> 310 | vsep (hsep (tupled ((((buf |># "define external ccc "#) `renderType` retTy) |># " @"#) `renderName` name) (zip [0..] args) renderArg |>. ' ') attrs renderFunctionAttr 311 | |># (if null attrs then "{\n"# else " {\n"#)) body renderBasicBlock |># "\n}"# 312 | where 313 | argTys = map fst args 314 | renderArg :: Renderer (Int, (Type, ParameterName)) 315 | renderArg buf' (i, (argTy, nm)) = 316 | let localRef = case nm of 317 | NoParameterName -> 318 | LocalRef argTy $ Name $ T.pack $ show i 319 | ParameterName paramName -> 320 | LocalRef argTy $ Name paramName 321 | in ((buf' `renderType` argTy) |>. ' ') `renderOperand` localRef 322 | {-# INLINEABLE renderGlobal #-} 323 | 324 | renderFunctionAttr :: Renderer FunctionAttribute 325 | renderFunctionAttr buf = \case 326 | AlwaysInline -> 327 | buf |># "alwaysinline"# 328 | WasmExportName name -> 329 | dquotes 330 | (dquotes buf (|># "wasm-export-name"#) |>. '=') 331 | (|> name) 332 | {-# INLINEABLE renderFunctionAttr #-} 333 | -------------------------------------------------------------------------------- /lib/LLVM/Codegen/Name.hs: -------------------------------------------------------------------------------- 1 | module LLVM.Codegen.Name 2 | ( Name(..) 3 | , unName 4 | , renderName 5 | ) where 6 | 7 | import Data.Text hiding (show) 8 | import Data.String 9 | import LLVM.Pretty 10 | 11 | data Name 12 | = Generated !Int 13 | | Name !Text 14 | deriving (Eq, Ord, Show) 15 | 16 | instance IsString Name where 17 | fromString = Name . fromString 18 | {-# INLINABLE fromString #-} 19 | 20 | unName :: Name -> Text 21 | unName = \case 22 | Name name -> name 23 | Generated x -> pack $! show x 24 | 25 | renderName :: Renderer Name 26 | renderName buf = \case 27 | Name name -> 28 | buf |> name 29 | Generated x -> 30 | buf |>$ x 31 | {-# INLINABLE renderName #-} 32 | -------------------------------------------------------------------------------- /lib/LLVM/Codegen/Operand.hs: -------------------------------------------------------------------------------- 1 | module LLVM.Codegen.Operand 2 | ( Operand(..) 3 | , Constant(..) 4 | , typeOf 5 | , renderOperand 6 | , renderConstant 7 | ) where 8 | 9 | import LLVM.Codegen.Name 10 | import LLVM.Codegen.Type 11 | import LLVM.Pretty 12 | import Data.Word 13 | 14 | 15 | data Constant 16 | = GlobalRef !Type !Name 17 | | Array !Type ![Constant] 18 | | Int !Word32 !Integer 19 | | NullPtr !Type 20 | | Undef !Type 21 | deriving (Eq, Ord, Show) 22 | 23 | data Operand 24 | = LocalRef !Type !Name 25 | | ConstantOperand !Constant 26 | deriving (Eq, Ord, Show) 27 | 28 | typeOf :: Operand -> Type 29 | typeOf = \case 30 | LocalRef ty _ -> 31 | ty 32 | ConstantOperand c -> 33 | typeOfConstant c 34 | where 35 | typeOfConstant = \case 36 | GlobalRef ty _ -> 37 | ty 38 | Array ty cs -> 39 | ArrayType (fromIntegral $ length cs) ty 40 | Int bits _ -> 41 | IntType bits 42 | NullPtr ty -> 43 | ptr ty 44 | Undef ty -> 45 | ty 46 | {-# INLINEABLE typeOf #-} 47 | 48 | renderConstant :: Renderer Constant 49 | renderConstant buf = \case 50 | GlobalRef _ name -> 51 | (buf |>. '@') `renderName` name 52 | Array ty cs -> 53 | brackets buf (\buf' -> commas buf' cs renderValue) 54 | where 55 | renderValue :: Renderer Constant 56 | renderValue buf' c = (renderType buf' ty |>. ' ') `renderConstant` c 57 | Int _bits x -> 58 | buf |>$ (fromInteger x :: Int) 59 | NullPtr _ -> 60 | buf |># "zeroinitializer"# 61 | Undef _ -> 62 | buf |># "undef"# 63 | 64 | renderOperand :: Renderer Operand 65 | renderOperand buf = \case 66 | LocalRef _ name -> 67 | (buf |>. '%') `renderName` name 68 | ConstantOperand c -> 69 | renderConstant buf c 70 | {-# INLINEABLE renderOperand #-} 71 | -------------------------------------------------------------------------------- /lib/LLVM/Codegen/Type.hs: -------------------------------------------------------------------------------- 1 | module LLVM.Codegen.Type 2 | ( Type(..) 3 | , Packed 4 | , i1 5 | , i8 6 | , i16 7 | , i32 8 | , i64 9 | , ptr 10 | , void 11 | , renderType 12 | ) where 13 | 14 | import LLVM.Codegen.Name 15 | import LLVM.Codegen.Flag 16 | import Data.Word 17 | import LLVM.Pretty 18 | 19 | data Packed 20 | 21 | data Type 22 | = IntType !Word32 23 | | FunctionType !Type ![Type] 24 | | PointerType !Type 25 | | VoidType 26 | | StructureType !(Flag Packed) ![Type] 27 | | ArrayType !Word32 !Type 28 | | NamedTypeReference !Name 29 | deriving (Eq, Ord, Show) 30 | 31 | i1, i8, i16, i32, i64 :: Type 32 | i1 = IntType 1 33 | i8 = IntType 8 34 | i16 = IntType 16 35 | i32 = IntType 32 36 | i64 = IntType 64 37 | 38 | ptr :: Type -> Type 39 | ptr = PointerType 40 | 41 | void :: Type 42 | void = VoidType 43 | 44 | renderType :: Renderer Type 45 | renderType buf = \case 46 | PointerType _ -> 47 | buf |># "ptr"# 48 | IntType bits -> 49 | buf |>. 'i' |>$ bits 50 | FunctionType retTy argTys -> 51 | tupled (renderType buf retTy |>. ' ') argTys renderType 52 | NamedTypeReference name -> 53 | (buf |>. '%') `renderName` name 54 | VoidType -> 55 | buf |># "void"# 56 | StructureType packed elemTys 57 | | packed == On -> 58 | commas (buf |># "<{"#) elemTys renderType |># "}>"# 59 | | otherwise -> 60 | braces buf (\buf' -> commas buf' elemTys renderType) 61 | ArrayType count ty -> 62 | brackets buf (\buf' -> (buf' |>$ count |># " x "#) `renderType` ty) 63 | {-# INLINABLE renderType #-} 64 | -------------------------------------------------------------------------------- /lib/LLVM/Pretty.hs: -------------------------------------------------------------------------------- 1 | module LLVM.Pretty 2 | ( Renderer 3 | , renderDoc 4 | , (|>) 5 | , (|>.) 6 | , (|>#) 7 | , (|>$) 8 | , Buffer 9 | , Addr# 10 | , runBuffer 11 | , consumeBuffer 12 | , hsep 13 | , vsep 14 | , sepBy 15 | , brackets 16 | , braces 17 | , parens 18 | , commas 19 | , dquotes 20 | , tupled 21 | , withIndent 22 | , optional 23 | , renderMaybe 24 | ) where 25 | 26 | import Prelude hiding (EQ) 27 | import Data.Text.Builder.Linear.Buffer 28 | import Data.Text (Text) 29 | import qualified Data.List as L 30 | import GHC.Prim (Addr#) 31 | import LLVM.Codegen.Flag 32 | 33 | type Renderer a = Buffer %1 -> a -> Buffer 34 | 35 | renderDoc :: Renderer a -> a -> Text 36 | renderDoc f d = 37 | runBuffer (`f` d) 38 | {-# INLINABLE renderDoc #-} 39 | 40 | -- TODO better name 41 | type BufferDecorator = Buffer %1 -> (Buffer %1 -> Buffer) -> Buffer 42 | 43 | brackets :: BufferDecorator 44 | brackets = betweenChars '[' ']' 45 | {-# INLINABLE brackets #-} 46 | 47 | braces :: BufferDecorator 48 | braces = betweenChars '{' '}' 49 | {-# INLINABLE braces #-} 50 | 51 | parens :: BufferDecorator 52 | parens = betweenChars '(' ')' 53 | {-# INLINABLE parens #-} 54 | 55 | dquotes :: BufferDecorator 56 | dquotes = betweenChars '"' '"' 57 | {-# INLINABLE dquotes #-} 58 | 59 | betweenChars :: Char -> Char -> BufferDecorator 60 | betweenChars begin end buf f = 61 | f (buf |>. begin) |>. end 62 | {-# INLINABLE betweenChars #-} 63 | 64 | withIndent :: BufferDecorator 65 | withIndent buf' f = 66 | f (buf' |># " "#) 67 | {-# INLINABLE withIndent #-} 68 | 69 | hsep :: Buffer %1 -> [a] -> Renderer a -> Buffer 70 | hsep = sepBy " "# 71 | {-# INLINABLE hsep #-} 72 | 73 | vsep :: Buffer %1 -> [a] -> Renderer a -> Buffer 74 | vsep = sepBy "\n"# 75 | {-# INLINABLE vsep #-} 76 | 77 | tupled :: Buffer %1 -> [a] -> Renderer a -> Buffer 78 | tupled buf as f = 79 | parens buf (\buf' -> commas buf' as f) 80 | {-# INLINABLE tupled #-} 81 | 82 | commas :: Buffer %1 -> [a] -> Renderer a -> Buffer 83 | commas = sepBy ", "# 84 | {-# INLINABLE commas #-} 85 | 86 | sepBy :: forall a. Addr# -> Buffer %1 -> [a] -> Renderer a -> Buffer 87 | sepBy separator buf as f = 88 | foldlIntoBuffer combine buf parts 89 | where 90 | parts = L.intersperse Nothing $ map Just as 91 | combine :: Renderer (Maybe a) 92 | combine buf' = \case 93 | Nothing -> 94 | buf' |># separator 95 | Just a -> 96 | f buf' a 97 | {-# INLINABLE sepBy #-} 98 | 99 | optional :: Flag a -> BufferDecorator 100 | optional flag buf f = case flag of 101 | Off -> buf 102 | On -> f buf 103 | {-# INLINABLE optional #-} 104 | 105 | renderMaybe :: Buffer %1 -> Maybe a -> Renderer a -> Buffer 106 | renderMaybe buf mValue render = 107 | case mValue of 108 | Nothing -> 109 | buf 110 | Just value -> 111 | render buf value 112 | {-# INLINABLE renderMaybe #-} 113 | -------------------------------------------------------------------------------- /llvm-codegen.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.0 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.35.2. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: llvm-codegen 8 | version: 0.1.0.0 9 | category: Compilers 10 | homepage: https://github.com/luc-tielen/llvm-codegen 11 | author: Luc Tielen 12 | maintainer: luc.tielen@gmail.com 13 | copyright: Luc Tielen, 2024 14 | license: BSD3 15 | license-file: LICENSE 16 | build-type: Custom 17 | extra-source-files: README.md 18 | synopsis: A DSL for LLVM IR code generation based on llvm-hs. 19 | description: 20 | A DSL for LLVM IR code generation. Heavily inspired by llvm-hs. 21 | 22 | custom-setup 23 | setup-depends: 24 | base <5 25 | , Cabal <4 26 | , containers 27 | 28 | library 29 | -- cabal-fmt: expand lib 30 | exposed-modules: 31 | LLVM.C.API 32 | LLVM.C.Bindings 33 | LLVM.Codegen 34 | LLVM.Codegen.Flag 35 | LLVM.Codegen.IR 36 | LLVM.Codegen.IRBuilder 37 | LLVM.Codegen.IRBuilder.Monad 38 | LLVM.Codegen.ModuleBuilder 39 | LLVM.Codegen.Name 40 | LLVM.Codegen.Operand 41 | LLVM.Codegen.Type 42 | LLVM.Pretty 43 | 44 | other-modules: Paths_llvm_codegen 45 | autogen-modules: Paths_llvm_codegen 46 | hs-source-dirs: lib 47 | default-extensions: 48 | DefaultSignatures 49 | DeriveAnyClass 50 | DeriveFoldable 51 | DeriveFunctor 52 | DeriveGeneric 53 | DeriveTraversable 54 | DerivingStrategies 55 | DerivingVia 56 | FlexibleContexts 57 | FlexibleInstances 58 | LambdaCase 59 | LinearTypes 60 | MagicHash 61 | OverloadedStrings 62 | ScopedTypeVariables 63 | TupleSections 64 | 65 | ghc-options: 66 | -Wall -fhide-source-paths -fno-show-valid-hole-fits 67 | -fno-sort-valid-hole-fits -optl=-lLLVM 68 | 69 | build-depends: 70 | base >=4.7 && <5 71 | , bytestring >=0.11 && <0.12 72 | , containers <1 73 | , dlist >=1 && <2 74 | , ghc-prim <1 75 | , mmorph >=1 && <2 76 | , mtl >=2 && <3 77 | , text >=2 && <3 78 | , text-builder-linear <1 79 | 80 | default-language: Haskell2010 81 | 82 | test-suite llvm-codegen-test 83 | type: exitcode-stdio-1.0 84 | main-is: test.hs 85 | other-modules: 86 | Paths_llvm_codegen 87 | Test.LLVM.C.APISpec 88 | Test.LLVM.Codegen.IRBuilderSpec 89 | Test.LLVM.Codegen.IRCombinatorsSpec 90 | 91 | autogen-modules: Paths_llvm_codegen 92 | hs-source-dirs: tests 93 | default-extensions: 94 | DefaultSignatures 95 | DeriveAnyClass 96 | DeriveFoldable 97 | DeriveFunctor 98 | DeriveGeneric 99 | DeriveTraversable 100 | DerivingStrategies 101 | DerivingVia 102 | FlexibleContexts 103 | FlexibleInstances 104 | LambdaCase 105 | LinearTypes 106 | MagicHash 107 | OverloadedStrings 108 | ScopedTypeVariables 109 | TupleSections 110 | 111 | ghc-options: 112 | -Wall -fhide-source-paths -fno-show-valid-hole-fits 113 | -fno-sort-valid-hole-fits -optl=-lLLVM 114 | 115 | build-depends: 116 | base >=4.7 && <5 117 | , bytestring >=0.11 && <0.12 118 | , containers <1 119 | , dlist >=1 && <2 120 | , ghc-prim <1 121 | , hspec >=2.6.1 && <3.0.0 122 | , hspec-hedgehog <1 123 | , llvm-codegen 124 | , mmorph >=1 && <2 125 | , mtl >=2 && <3 126 | , neat-interpolation <1 127 | , text >=2 && <3 128 | , text-builder-linear <1 129 | 130 | default-language: Haskell2010 131 | -------------------------------------------------------------------------------- /tests/Test/LLVM/C/APISpec.hs: -------------------------------------------------------------------------------- 1 | module Test.LLVM.C.APISpec 2 | ( module Test.LLVM.C.APISpec 3 | ) where 4 | 5 | import Test.Hspec 6 | import Foreign hiding (void) 7 | import qualified LLVM.C.API as C 8 | import LLVM.Codegen.Type 9 | import LLVM.Codegen.Name 10 | import LLVM.Codegen.Flag 11 | 12 | -- NOTE: if it can't find libffi, you're linking against wrong libLLVM! 13 | -- Be sure to update Setup.hs LLVM version as well to be in sync! 14 | 15 | mkType :: ForeignPtr C.Context -> Type -> IO (Ptr C.Type) 16 | mkType ctx = \case 17 | VoidType -> 18 | C.mkVoidType ctx 19 | IntType bits -> 20 | C.mkIntType ctx bits 21 | PointerType ty -> 22 | C.mkPointerType =<< mkType ctx ty 23 | StructureType packed tys -> do 24 | tys' <- traverse (mkType ctx) tys 25 | C.mkAnonStructType ctx tys' packed 26 | ArrayType count ty -> do 27 | ty' <- mkType ctx ty 28 | C.mkArrayType ty' count 29 | FunctionType retTy argTys -> do 30 | retTy' <- mkType ctx retTy 31 | argTys' <- traverse (mkType ctx) argTys 32 | C.mkFunctionType retTy' argTys' 33 | NamedTypeReference name -> 34 | C.getTypeByName ctx name 35 | 36 | 37 | -- TODO: do more than checking against nullptr in first tests 38 | 39 | spec :: Spec 40 | spec = describe "LLVM C API" $ parallel $ do 41 | it "can create a LLVM context" $ do 42 | ctx <- C.mkContext 43 | withForeignPtr ctx $ \c -> 44 | c `shouldNotBe` nullPtr 45 | 46 | it "can create an empty LLVM module" $ do 47 | ctx <- C.mkContext 48 | llvmMod <- C.mkModule ctx "test" 49 | withForeignPtr llvmMod $ \llvmModule -> 50 | llvmModule `shouldNotBe` nullPtr 51 | 52 | it "can set the target data for a LLVM module" $ do 53 | ctx <- C.mkContext 54 | 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 55 | llvmMod <- C.mkModule ctx "test" 56 | C.setTargetData llvmMod newTd 57 | td <- C.getTargetData llvmMod 58 | td `shouldNotBe` nullPtr 59 | 60 | it "can extract the target data from a LLVM module" $ do 61 | ctx <- C.mkContext 62 | llvmMod <- C.mkModule ctx "test" 63 | td <- C.getTargetData llvmMod 64 | td `shouldNotBe` nullPtr 65 | 66 | let assertTypeSizes :: ((Type -> Word64 -> IO ()) -> IO ()) -> IO () 67 | assertTypeSizes f = do 68 | ctx <- C.mkContext 69 | llvmMod <- C.mkModule ctx "test" 70 | td <- C.getTargetData llvmMod 71 | f $ \ty expectedSize -> do 72 | ty' <- mkType ctx ty 73 | actualSize <- C.sizeOfType td ty' 74 | actualSize `shouldBe` expectedSize 75 | 76 | it "can compute the size of an integer type" $ do 77 | assertTypeSizes $ \assert -> do 78 | assert i1 1 79 | assert i8 1 80 | assert i16 2 81 | assert i32 4 82 | assert i64 8 83 | 84 | -- NOTE: not allowed for "void" => has no size, causes SIGILL (due to missing return in a function in libLLVM / assert triggered) 85 | 86 | it "can compute the size of a pointer type" $ do 87 | assertTypeSizes $ \assert -> do 88 | assert (ptr i1) 8 89 | assert (ptr i32) 8 90 | assert (ptr i64) 8 91 | 92 | it "can compute the size of a struct type" $ do 93 | assertTypeSizes $ \assert -> do 94 | assert (StructureType Off [i8]) 1 95 | assert (StructureType Off [i8, i8]) 2 96 | assert (StructureType Off [i8, i16]) 4 -- padding! 97 | assert (StructureType On [i8, i16]) 3 98 | assert (StructureType On [i8, StructureType Off [i8]]) 2 99 | assert (StructureType Off [ArrayType 5 i32, i1]) 24 -- padding! 100 | assert (StructureType On [ArrayType 5 i32, i1]) 21 101 | assert (StructureType On [i32, i64]) 12 -- no padding, 4-byte alignment for i64? 102 | 103 | it "can compute the size of an array type" $ do 104 | assertTypeSizes $ \assert -> do 105 | assert (ArrayType 1 i1) 1 106 | assert (ArrayType 10 i1) 10 107 | assert (ArrayType 10 i32) 40 108 | assert (ArrayType 5 (StructureType Off [i32, i64])) (5 * 12) 109 | 110 | -- NOTE: not allowed for function type => has no size, triggers undefined behavior. 111 | 112 | it "returns null for an unknown named type reference" $ do 113 | let ty = NamedTypeReference $ Name "unknown" 114 | ctx <- C.mkContext 115 | ty' <- mkType ctx ty 116 | ty' `shouldBe` nullPtr 117 | 118 | -- TODO test for known named type ref, but need to first add to module 119 | -------------------------------------------------------------------------------- /tests/Test/LLVM/Codegen/IRBuilderSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes, RecursiveDo #-} 2 | {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} 3 | 4 | module Test.LLVM.Codegen.IRBuilderSpec 5 | ( module Test.LLVM.Codegen.IRBuilderSpec 6 | ) where 7 | 8 | import Prelude hiding (and, or, EQ) 9 | import qualified Data.Text as T 10 | import Data.Foldable hiding (and, or) 11 | import Test.Hspec 12 | import NeatInterpolation 13 | import Data.Text (Text) 14 | import LLVM.Codegen 15 | 16 | 17 | checkIR :: ModuleBuilder a -> Text -> IO () 18 | checkIR llvmModule expectedOutput = do 19 | let ir = ppllvm $ runModuleBuilder llvmModule 20 | ir `shouldBe` expectedOutput 21 | 22 | spec :: Spec 23 | spec = describe "constructing LLVM IR" $ do 24 | -- Module level 25 | 26 | it "supports an empty module" $ do 27 | let ir = pure () 28 | checkIR ir "" 29 | 30 | it "supports global constants" $ do 31 | let ir = global "my_constant" i32 (Int 32 42) 32 | checkIR ir [text| 33 | @my_constant = global i32 42 34 | |] 35 | let ir2 = do 36 | _ <- global "my_constant" i32 (Int 32 42) 37 | global "my_constant2" i64 (Int 64 1000) 38 | checkIR ir2 [text| 39 | @my_constant = global i32 42 40 | 41 | @my_constant2 = global i64 1000 42 | |] 43 | 44 | it "supports creating and using global utf8 string constants" $ do 45 | let ir = do 46 | function "utf8_string_usage" [] i8 $ \[] -> do 47 | str <- globalUtf8StringPtr "string_contents" "my_string" 48 | char <- load str 0 49 | ret char 50 | checkIR ir [text| 51 | @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] 52 | 53 | define external ccc i8 @utf8_string_usage() { 54 | start: 55 | %0 = getelementptr inbounds [16 x i8], ptr @my_string, i32 0, i32 0 56 | %1 = load i8, ptr %0 57 | ret i8 %1 58 | } 59 | |] 60 | 61 | it "supports type definitions" $ do 62 | let ir = mdo 63 | let myType = ArrayType 10 i16 64 | _ <- typedef "my_type2" Off [myType, myType] 65 | _ <- typedef "my_type2_packed" On [myType, myType] 66 | _ <- typedef "struct_with_ptrs" Off [ptr i8, ptr i16] 67 | s <- typedef "recursive" Off [ptr s] 68 | _ <- opaqueTypedef "my_opaque_type" 69 | pure () 70 | checkIR ir [text| 71 | %my_type2 = type {[10 x i16], [10 x i16]} 72 | 73 | %my_type2_packed = type <{[10 x i16], [10 x i16]}> 74 | 75 | %struct_with_ptrs = type {ptr, ptr} 76 | 77 | %recursive = type {ptr} 78 | 79 | %my_opaque_type = type opaque 80 | |] 81 | 82 | it "supports external definitions" $ do 83 | let ir = do 84 | _ <- extern "symbol1" [i32, i64] (ptr i8) 85 | extern "symbol2" [] (ptr i8) 86 | checkIR ir [text| 87 | declare external ccc ptr @symbol1(i32, i64) 88 | 89 | declare external ccc ptr @symbol2() 90 | |] 91 | 92 | it "supports functions" $ do 93 | let ir = do 94 | function "do_add" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> do 95 | c <- add a b 96 | ret c 97 | checkIR ir [text| 98 | define external ccc i32 @do_add(i32 %a_0, i32 %b_0) { 99 | start: 100 | %0 = add i32 %a_0, %b_0 101 | ret i32 %0 102 | } 103 | |] 104 | let ir2 = do 105 | function "func_with_ptrs" [(ptr i32, "a"), (ptr i8, "b")] (ptr i32) $ \[a, _b] -> do 106 | ret a 107 | checkIR ir2 [text| 108 | define external ccc ptr @func_with_ptrs(ptr %a_0, ptr %b_0) { 109 | start: 110 | ret ptr %a_0 111 | } 112 | |] 113 | 114 | it "renders functions in order they are defined" $ do 115 | let ir = do 116 | _ <- function "do_add" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> do 117 | c <- add a b 118 | ret c 119 | function "do_add2" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> do 120 | c <- add a b 121 | ret c 122 | checkIR ir [text| 123 | define external ccc i32 @do_add(i32 %a_0, i32 %b_0) { 124 | start: 125 | %0 = add i32 %a_0, %b_0 126 | ret i32 %0 127 | } 128 | 129 | define external ccc i32 @do_add2(i32 %a_0, i32 %b_0) { 130 | start: 131 | %0 = add i32 %a_0, %b_0 132 | ret i32 %0 133 | } 134 | |] 135 | 136 | -- IR level 137 | 138 | it "supports defining basic blocks" $ do 139 | let ir = do 140 | function "do_add" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> do 141 | _ <- block 142 | c <- add a b 143 | ret c 144 | checkIR ir [text| 145 | define external ccc i32 @do_add(i32 %a_0, i32 %b_0) { 146 | start: 147 | br label %block_0 148 | block_0: 149 | %0 = add i32 %a_0, %b_0 150 | ret i32 %0 151 | } 152 | |] 153 | 154 | it "supports giving a basic block a user-defined name" $ do 155 | let ir = do 156 | function "do_add" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> do 157 | c <- add a b 158 | ret c 159 | checkIR ir [text| 160 | define external ccc i32 @do_add(i32 %a_0, i32 %b_0) { 161 | start: 162 | %0 = add i32 %a_0, %b_0 163 | ret i32 %0 164 | } 165 | |] 166 | 167 | it "supports giving function parameters a user-defined name" $ do 168 | let ir = do 169 | function "do_add" [(i32, "arg0"), (i32, "arg1")] i32 $ \[a, b] -> do 170 | c <- add a b 171 | ret c 172 | checkIR ir [text| 173 | define external ccc i32 @do_add(i32 %arg0_0, i32 %arg1_0) { 174 | start: 175 | %0 = add i32 %arg0_0, %arg1_0 176 | ret i32 %0 177 | } 178 | |] 179 | 180 | it "supports automatic naming of function parameters" $ do 181 | let ir = do 182 | function "do_add" [(i32, NoParameterName), (i32, NoParameterName)] i32 $ \[a, b] -> do 183 | c <- add a b 184 | ret c 185 | checkIR ir [text| 186 | define external ccc i32 @do_add(i32 %0, i32 %1) { 187 | start: 188 | %2 = add i32 %0, %1 189 | ret i32 %2 190 | } 191 | |] 192 | 193 | it "automatically terminates previous basic block when starting new block" $ do 194 | let ir = do 195 | function "do_add" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> mdo 196 | c <- add a b 197 | -- NOTE: invalid IR 198 | _ <- blockNamed "next" 199 | ret c 200 | checkIR ir [text| 201 | define external ccc i32 @do_add(i32 %a_0, i32 %b_0) { 202 | start: 203 | %0 = add i32 %a_0, %b_0 204 | ret void 205 | next_0: 206 | ret i32 %0 207 | } 208 | |] 209 | 210 | it "avoids name collisions by appending a unique suffix" $ do 211 | let ir = do 212 | function "do_add" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> mdo 213 | _ <- blockNamed "blk" 214 | c <- add a b 215 | _ <- add c c 216 | br blk2 217 | blk2 <- blockNamed "blk" 218 | ret c 219 | checkIR ir [text| 220 | define external ccc i32 @do_add(i32 %a_0, i32 %b_0) { 221 | start: 222 | br label %blk_0 223 | blk_0: 224 | %0 = add i32 %a_0, %b_0 225 | %1 = add i32 %0, %0 226 | br label %blk_1 227 | blk_1: 228 | ret i32 %0 229 | } 230 | |] 231 | 232 | it "shifts allocas to start of the entry basic block" $ do 233 | let ir = do 234 | function "func" [(i32, "a")] i32 $ \[a] -> mdo 235 | _ <- alloca i32 Nothing 0 236 | b <- add a a 237 | br blk 238 | blk <- blockNamed "blk" 239 | _ <- alloca i64 Nothing 0 240 | c <- add b b 241 | ret c 242 | checkIR ir [text| 243 | define external ccc i32 @func(i32 %a_0) { 244 | start: 245 | %stack.ptr_0 = alloca i32 246 | %stack.ptr_1 = alloca i64 247 | %0 = add i32 %a_0, %a_0 248 | br label %blk_0 249 | blk_0: 250 | %1 = add i32 %0, %0 251 | ret i32 %1 252 | } 253 | |] 254 | 255 | it "supports 'add' instruction" $ do 256 | let ir = do 257 | function "do_add" [(i8, "a"), (i8, "b")] i8 $ \[a, b] -> do 258 | c <- add a b 259 | ret c 260 | checkIR ir [text| 261 | define external ccc i8 @do_add(i8 %a_0, i8 %b_0) { 262 | start: 263 | %0 = add i8 %a_0, %b_0 264 | ret i8 %0 265 | } 266 | |] 267 | 268 | it "supports 'mul' instruction" $ do 269 | let ir = do 270 | function "func" [(i8, "a"), (i8, "b")] i8 $ \[a, b] -> do 271 | c <- mul a b 272 | ret c 273 | checkIR ir [text| 274 | define external ccc i8 @func(i8 %a_0, i8 %b_0) { 275 | start: 276 | %0 = mul i8 %a_0, %b_0 277 | ret i8 %0 278 | } 279 | |] 280 | 281 | it "supports 'sub' instruction" $ do 282 | let ir = do 283 | function "func" [(i8, "a"), (i8, "b")] i8 $ \[a, b] -> do 284 | c <- sub a b 285 | ret c 286 | checkIR ir [text| 287 | define external ccc i8 @func(i8 %a_0, i8 %b_0) { 288 | start: 289 | %0 = sub i8 %a_0, %b_0 290 | ret i8 %0 291 | } 292 | |] 293 | 294 | it "supports 'udiv' instruction" $ do 295 | let ir = do 296 | function "func" [(i8, "a"), (i8, "b")] i8 $ \[a, b] -> do 297 | c <- udiv a b 298 | ret c 299 | checkIR ir [text| 300 | define external ccc i8 @func(i8 %a_0, i8 %b_0) { 301 | start: 302 | %0 = udiv i8 %a_0, %b_0 303 | ret i8 %0 304 | } 305 | |] 306 | 307 | it "supports 'and' instruction" $ do 308 | let ir = do 309 | function "func" [(i1, "a"), (i1, "b")] i1 $ \[a, b] -> do 310 | c <- and a b 311 | ret c 312 | checkIR ir [text| 313 | define external ccc i1 @func(i1 %a_0, i1 %b_0) { 314 | start: 315 | %0 = and i1 %a_0, %b_0 316 | ret i1 %0 317 | } 318 | |] 319 | 320 | it "supports 'or' instruction" $ do 321 | let ir = do 322 | function "func" [(i1, "a"), (i1, "b")] i1 $ \[a, b] -> do 323 | c <- or a b 324 | ret c 325 | checkIR ir [text| 326 | define external ccc i1 @func(i1 %a_0, i1 %b_0) { 327 | start: 328 | %0 = or i1 %a_0, %b_0 329 | ret i1 %0 330 | } 331 | |] 332 | 333 | it "supports 'trunc' instruction" $ do 334 | let ir = do 335 | function "func" [(i64, "a")] i32 $ \[a] -> do 336 | b <- trunc a i32 337 | ret b 338 | checkIR ir [text| 339 | define external ccc i32 @func(i64 %a_0) { 340 | start: 341 | %0 = trunc i64 %a_0 to i32 342 | ret i32 %0 343 | } 344 | |] 345 | 346 | it "supports 'zext' instruction" $ do 347 | let ir = do 348 | function "func" [(i32, "a")] i64 $ \[a] -> do 349 | b <- zext a i64 350 | ret b 351 | checkIR ir [text| 352 | define external ccc i64 @func(i32 %a_0) { 353 | start: 354 | %0 = zext i32 %a_0 to i64 355 | ret i64 %0 356 | } 357 | |] 358 | 359 | it "supports 'ptrtoint' instruction" $ do 360 | let ir = do 361 | function "func" [(ptr i32, "ptr_a")] i64 $ \[a] -> do 362 | b <- ptrtoint a i64 363 | ret b 364 | checkIR ir [text| 365 | define external ccc i64 @func(ptr %ptr_a_0) { 366 | start: 367 | %0 = ptrtoint ptr %ptr_a_0 to i64 368 | ret i64 %0 369 | } 370 | |] 371 | 372 | it "supports 'bitcast' instruction" $ do 373 | -- TODO improve example once vector or float types are added 374 | let ir = do 375 | function "func" [(ptr i32, "ptr_a")] (ptr i64) $ \[a] -> do 376 | b <- a `bitcast` ptr i64 377 | ret b 378 | checkIR ir [text| 379 | define external ccc ptr @func(ptr %ptr_a_0) { 380 | start: 381 | %0 = bitcast ptr %ptr_a_0 to ptr 382 | ret ptr %0 383 | } 384 | |] 385 | 386 | it "supports 'icmp' instruction" $ do 387 | let scenarios = 388 | [ (EQ, "eq") 389 | , (NE, "ne") 390 | , (ULE, "ule") 391 | , (UGT, "ugt") 392 | , (UGE, "uge") 393 | , (UGT, "ugt") 394 | , (SLE, "sle") 395 | , (SLT, "slt") 396 | , (SGE, "sge") 397 | , (SGT, "sgt") 398 | ] 399 | for_ scenarios $ \(cmp, cmpText) -> do 400 | let ir = do 401 | function "func" [(i32, "a"), (i32, "b")] i1 $ \[a, b] -> do 402 | c <- icmp cmp a b 403 | ret c 404 | ir2 = do 405 | function "func2" [(ptr i32, "a"), (ptr i32, "b")] i1 $ \[a, b] -> do 406 | c <- icmp cmp a b 407 | ret c 408 | checkIR ir [text| 409 | define external ccc i1 @func(i32 %a_0, i32 %b_0) { 410 | start: 411 | %0 = icmp $cmpText i32 %a_0, %b_0 412 | ret i1 %0 413 | } 414 | |] 415 | checkIR ir2 [text| 416 | define external ccc i1 @func2(ptr %a_0, ptr %b_0) { 417 | start: 418 | %0 = icmp $cmpText ptr %a_0, %b_0 419 | ret i1 %0 420 | } 421 | |] 422 | 423 | it "supports 'alloca' instruction" $ do 424 | let ir = do 425 | function "func" [(i32, "a")] i32 $ \[a] -> do 426 | _ <- alloca i64 Nothing 0 427 | _ <- alloca i1 (Just $ int32 8) 0 428 | _ <- alloca i1 Nothing 8 429 | ret a 430 | checkIR ir [text| 431 | define external ccc i32 @func(i32 %a_0) { 432 | start: 433 | %stack.ptr_0 = alloca i64 434 | %stack.ptr_1 = alloca i1, i32 8 435 | %stack.ptr_2 = alloca i1, align 8 436 | ret i32 %a_0 437 | } 438 | |] 439 | 440 | it "supports 'gep' instruction on pointers" $ do 441 | let ir = do 442 | function "func" [(ptr i64, "a"), (ptr (ptr (ptr i64)), "b")] (ptr i64) $ \[a, b] -> do 443 | c <- gep a [int32 1] 444 | _ <- gep b [int32 2] 445 | ret c 446 | checkIR ir [text| 447 | define external ccc ptr @func(ptr %a_0, ptr %b_0) { 448 | start: 449 | %0 = getelementptr i64, ptr %a_0, i32 1 450 | %1 = getelementptr ptr, ptr %b_0, i32 2 451 | ret ptr %0 452 | } 453 | |] 454 | 455 | it "supports 'gep' instruction on structs" $ do 456 | let ir = do 457 | struct1 <- typedef "my_struct" Off [i32, i64] 458 | struct2 <- typedef "my_struct2" Off [struct1, i1] 459 | 460 | function "func" [(ptr struct2, "a")] (ptr i64) $ \[a] -> do 461 | c <- gep a [int32 0, int32 0, int32 1] 462 | _ <- gep a [int32 0, int32 1] 463 | ret c 464 | checkIR ir [text| 465 | %my_struct = type {i32, i64} 466 | 467 | %my_struct2 = type {%my_struct, i1} 468 | 469 | define external ccc ptr @func(ptr %a_0) { 470 | start: 471 | %0 = getelementptr %my_struct2, ptr %a_0, i32 0, i32 0, i32 1 472 | %1 = getelementptr %my_struct2, ptr %a_0, i32 0, i32 1 473 | ret ptr %0 474 | } 475 | |] 476 | 477 | it "supports 'gep' instruction on arrays" $ do 478 | let ir = do 479 | let array = ArrayType 10 i32 480 | 481 | function "func" [(ptr array, "a")] (ptr i32) $ \[a] -> do 482 | c <- gep a [int32 0, int32 5] 483 | ret c 484 | checkIR ir [text| 485 | define external ccc ptr @func(ptr %a_0) { 486 | start: 487 | %0 = getelementptr [10 x i32], ptr %a_0, i32 0, i32 5 488 | ret ptr %0 489 | } 490 | |] 491 | 492 | it "supports 'load' instruction" $ do 493 | let ir = do 494 | function "func" [(ptr i64, "a")] i64 $ \[a] -> do 495 | b <- load a 0 496 | _ <- load a 8 497 | ret b 498 | checkIR ir [text| 499 | define external ccc i64 @func(ptr %a_0) { 500 | start: 501 | %0 = load i64, ptr %a_0 502 | %1 = load i64, ptr %a_0, align 8 503 | ret i64 %0 504 | } 505 | |] 506 | 507 | it "supports 'store' instruction" $ do 508 | let ir = do 509 | function "func" [(ptr i64, "a")] void $ \[a] -> do 510 | store a 0 (int64 10) 511 | store a 8 (int64 10) 512 | retVoid 513 | checkIR ir [text| 514 | define external ccc void @func(ptr %a_0) { 515 | start: 516 | store i64 10, ptr %a_0 517 | store i64 10, ptr %a_0, align 8 518 | ret void 519 | } 520 | |] 521 | 522 | it "supports 'phi' instruction" $ do 523 | let ir = do 524 | function "func" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> mdo 525 | c <- icmp EQ a b 526 | condBr c block1 block2 527 | 528 | block1 <- block 529 | br block3 530 | 531 | block2 <- block 532 | br block3 533 | 534 | block3 <- block 535 | d <- phi [(a, block1), (b, block2)] 536 | ret d 537 | checkIR ir [text| 538 | define external ccc i32 @func(i32 %a_0, i32 %b_0) { 539 | start: 540 | %0 = icmp eq i32 %a_0, %b_0 541 | br i1 %0, label %block_0, label %block_1 542 | block_0: 543 | br label %block_2 544 | block_1: 545 | br label %block_2 546 | block_2: 547 | %1 = phi i32 [%a_0, %block_0], [%b_0, %block_1] 548 | ret i32 %1 549 | } 550 | |] 551 | let ir2 = do 552 | function "func" [(ptr i32, "a"), (ptr i32, "b")] (ptr i32) $ \[a, b] -> mdo 553 | c <- icmp EQ a b 554 | condBr c block1 block2 555 | 556 | block1 <- block 557 | br block3 558 | 559 | block2 <- block 560 | br block3 561 | 562 | block3 <- block 563 | d <- phi [(a, block1), (b, block2)] 564 | ret d 565 | checkIR ir2 [text| 566 | define external ccc ptr @func(ptr %a_0, ptr %b_0) { 567 | start: 568 | %0 = icmp eq ptr %a_0, %b_0 569 | br i1 %0, label %block_0, label %block_1 570 | block_0: 571 | br label %block_2 572 | block_1: 573 | br label %block_2 574 | block_2: 575 | %1 = phi ptr [%a_0, %block_0], [%b_0, %block_1] 576 | ret ptr %1 577 | } 578 | |] 579 | 580 | 581 | it "supports 'call' instruction" $ do 582 | let ir = mdo 583 | func <- function "func" [(i32, "a")] i32 $ \[a] -> do 584 | ret =<< call func [a] 585 | 586 | func2 <- function "func2" [(ptr i32, "a")] i32 $ \[a] -> do 587 | ret =<< call func2 [a] 588 | 589 | pure () 590 | checkIR ir [text| 591 | define external ccc i32 @func(i32 %a_0) { 592 | start: 593 | %0 = call ccc i32 @func(i32 %a_0) 594 | ret i32 %0 595 | } 596 | 597 | define external ccc i32 @func2(ptr %a_0) { 598 | start: 599 | %0 = call ccc i32 @func2(ptr %a_0) 600 | ret i32 %0 601 | } 602 | |] 603 | 604 | it "supports 'ret' instruction" $ do 605 | let ir = do 606 | function "func" [(i1, "a")] i1 $ \[a] -> do 607 | ret a 608 | checkIR ir [text| 609 | define external ccc i1 @func(i1 %a_0) { 610 | start: 611 | ret i1 %a_0 612 | } 613 | |] 614 | let ir2 = do 615 | function "func" [(ptr i1, "a")] (ptr i1) $ \[a] -> do 616 | ret a 617 | checkIR ir2 [text| 618 | define external ccc ptr @func(ptr %a_0) { 619 | start: 620 | ret ptr %a_0 621 | } 622 | |] 623 | 624 | 625 | it "supports 'retVoid' instruction" $ do 626 | let ir = do 627 | function "func" [] void $ \[] -> do 628 | retVoid 629 | checkIR ir [text| 630 | define external ccc void @func() { 631 | start: 632 | ret void 633 | } 634 | |] 635 | 636 | it "only uses first terminator instruction" $ do 637 | let ir = do 638 | function "func" [] i1 $ \[] -> do 639 | ret (bit 0) 640 | ret (bit 1) 641 | checkIR ir [text| 642 | define external ccc i1 @func() { 643 | start: 644 | ret i1 0 645 | } 646 | |] 647 | 648 | it "doesn't emit a block if it has no instructions or terminator" $ do 649 | let ir = do 650 | function "func" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> mdo 651 | isZero <- eq a (int32 0) 652 | if' isZero $ do 653 | _ <- add a b 654 | ret $ int32 1000 655 | br blk 656 | 657 | blk <- block 658 | ret b 659 | checkIR ir [text| 660 | define external ccc i32 @func(i32 %a_0, i32 %b_0) { 661 | start: 662 | %0 = icmp eq i32 %a_0, 0 663 | br i1 %0, label %if_0, label %end_if_0 664 | if_0: 665 | %1 = add i32 %a_0, %b_0 666 | ret i32 1000 667 | end_if_0: 668 | br label %block_0 669 | block_0: 670 | ret i32 %b_0 671 | } 672 | |] 673 | 674 | it "supports 'br' instruction" $ do 675 | let ir = do 676 | function "func" [(i1, "a")] i1 $ \[a] -> mdo 677 | br block2 678 | 679 | block1 <- block 680 | ret a 681 | 682 | block2 <- block 683 | br block1 684 | checkIR ir [text| 685 | define external ccc i1 @func(i1 %a_0) { 686 | start: 687 | br label %block_1 688 | block_0: 689 | ret i1 %a_0 690 | block_1: 691 | br label %block_0 692 | } 693 | |] 694 | 695 | it "supports 'condBr' instruction" $ do 696 | let ir = do 697 | function "func" [(i1, "a")] i1 $ \[a] -> mdo 698 | condBr a block1 block2 699 | 700 | block1 <- block 701 | ret a 702 | 703 | block2 <- block 704 | condBr a block1 block3 705 | 706 | block3 <- block 707 | condBr a block1 block2 708 | checkIR ir [text| 709 | define external ccc i1 @func(i1 %a_0) { 710 | start: 711 | br i1 %a_0, label %block_0, label %block_1 712 | block_0: 713 | ret i1 %a_0 714 | block_1: 715 | br i1 %a_0, label %block_0, label %block_2 716 | block_2: 717 | br i1 %a_0, label %block_0, label %block_1 718 | } 719 | |] 720 | 721 | it "supports 'switch' instruction" $ do 722 | let ir = do 723 | function "func" [(i1, "a")] i1 $ \[a] -> mdo 724 | switch a defaultBlock [(bit 1, block1), (bit 0, block2)] 725 | block1 <- block 726 | ret a 727 | block2 <- block 728 | ret a 729 | defaultBlock <- block 730 | ret a 731 | checkIR ir [text| 732 | define external ccc i1 @func(i1 %a_0) { 733 | start: 734 | switch i1 %a_0, label %block_2 [i1 1, label %block_0 i1 0, label %block_1] 735 | block_0: 736 | ret i1 %a_0 737 | block_1: 738 | ret i1 %a_0 739 | block_2: 740 | ret i1 %a_0 741 | } 742 | |] 743 | 744 | 745 | it "supports 'select' instruction" $ do 746 | let ir = do 747 | function "not" [(i1, "a")] i1 $ \[a] -> do 748 | b <- select a (bit 0) (bit 1) 749 | ret b 750 | checkIR ir [text| 751 | define external ccc i1 @not(i1 %a_0) { 752 | start: 753 | %0 = select i1 %a_0, i1 0, i1 1 754 | ret i1 %0 755 | } 756 | |] 757 | let ir2 = do 758 | function "with_ptrs" [(i1, "bool"), (ptr i8, "a"), (ptr i8, "b")] (ptr i8) $ \[boolean, a, b] -> do 759 | c <- select boolean a b 760 | ret c 761 | checkIR ir2 [text| 762 | define external ccc ptr @with_ptrs(i1 %bool_0, ptr %a_0, ptr %b_0) { 763 | start: 764 | %0 = select i1 %bool_0, ptr %a_0, ptr %b_0 765 | ret ptr %0 766 | } 767 | |] 768 | 769 | it "supports 'bit' for creating i1 values" $ do 770 | let ir = do 771 | function "func" [] i1 $ \[] -> do 772 | ret (bit 1) 773 | checkIR ir [text| 774 | define external ccc i1 @func() { 775 | start: 776 | ret i1 1 777 | } 778 | |] 779 | let ir2 = do 780 | function "func" [] i1 $ \[] -> do 781 | ret (bit 0) 782 | checkIR ir2 [text| 783 | define external ccc i1 @func() { 784 | start: 785 | ret i1 0 786 | } 787 | |] 788 | 789 | it "supports 'int8' for creating i8 values" $ do 790 | let ir = do 791 | function "func" [] i8 $ \[] -> do 792 | ret (int8 15) 793 | checkIR ir [text| 794 | define external ccc i8 @func() { 795 | start: 796 | ret i8 15 797 | } 798 | |] 799 | 800 | it "supports 'int16' for creating i16 values" $ do 801 | let ir = do 802 | function "func" [] i16 $ \[] -> do 803 | ret (int16 30) 804 | checkIR ir [text| 805 | define external ccc i16 @func() { 806 | start: 807 | ret i16 30 808 | } 809 | |] 810 | 811 | it "supports 'int32' for creating i32 values" $ do 812 | let ir = do 813 | function "func" [] i32 $ \[] -> do 814 | ret (int32 60) 815 | checkIR ir [text| 816 | define external ccc i32 @func() { 817 | start: 818 | ret i32 60 819 | } 820 | |] 821 | 822 | it "supports 'int64' for creating i64 values" $ do 823 | let ir = do 824 | function "func" [] i64 $ \[] -> do 825 | ret (int64 120) 826 | checkIR ir [text| 827 | define external ccc i64 @func() { 828 | start: 829 | ret i64 120 830 | } 831 | |] 832 | 833 | it "supports 'intN' for creating iN values" $ do 834 | let ir = do 835 | function "func" [] (IntType 42) $ \[] -> do 836 | ret (intN 42 1000) 837 | checkIR ir [text| 838 | define external ccc i42 @func() { 839 | start: 840 | ret i42 1000 841 | } 842 | |] 843 | 844 | it "supports 'nullPtr' for creating null values" $ do 845 | let ir = do 846 | function "func" [] (ptr i8) $ \[] -> do 847 | ret $ nullPtr i8 848 | checkIR ir [text| 849 | define external ccc ptr @func() { 850 | start: 851 | ret ptr zeroinitializer 852 | } 853 | |] 854 | 855 | describe "function attributes" $ parallel $ do 856 | let checkAttr attr attrStr = 857 | it ("supports " <> T.unpack attrStr) $ do 858 | let ir = withFunctionAttributes (const [attr]) $ 859 | function "func" [] (IntType 42) $ \[] -> do 860 | ret (intN 42 1000) 861 | checkIR ir [text| 862 | define external ccc i42 @func() $attrStr { 863 | start: 864 | ret i42 1000 865 | } 866 | |] 867 | 868 | checkAttr AlwaysInline "alwaysinline" 869 | checkAttr (WasmExportName "test") "\"wasm-export-name\"=\"test\"" 870 | 871 | it "supports multiple function attributes" $ do 872 | let attrs = [AlwaysInline, WasmExportName "test"] 873 | ir = withFunctionAttributes (const attrs) $ 874 | function "func" [] (IntType 42) $ \[] -> do 875 | ret (intN 42 1000) 876 | checkIR ir [text| 877 | define external ccc i42 @func() alwaysinline "wasm-export-name"="test" { 878 | start: 879 | ret i42 1000 880 | } 881 | |] 882 | -------------------------------------------------------------------------------- /tests/Test/LLVM/Codegen/IRCombinatorsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes, RecursiveDo, OverloadedLists #-} 2 | {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} 3 | 4 | module Test.LLVM.Codegen.IRCombinatorsSpec 5 | ( module Test.LLVM.Codegen.IRCombinatorsSpec 6 | ) where 7 | 8 | import Test.Hspec 9 | import Data.Foldable (for_) 10 | import LLVM.Codegen 11 | import Data.Text (Text) 12 | import NeatInterpolation 13 | 14 | checkIR :: ModuleBuilder a -> Text -> IO () 15 | checkIR llvmModule expectedOutput = do 16 | let ir = ppllvm $ runModuleBuilder llvmModule 17 | ir `shouldBe` expectedOutput 18 | 19 | spec :: Spec 20 | spec = describe "IR builder combinators" $ parallel $ do 21 | it "supports comparisons combinators" $ do 22 | let scenarios :: [(Operand -> Operand -> IRBuilderT ModuleBuilder Operand, Text)] 23 | scenarios = [ (eq, "eq"), (ne, "ne") 24 | , (sge, "sge"), (sgt, "sgt"), (slt, "slt"), (sle, "sle") 25 | , (uge, "uge"), (ugt, "ugt"), (ult, "ult"), (ule, "ule") 26 | ] 27 | for_ scenarios $ \(f, op) -> do 28 | let ir = do 29 | function "func" [(i32, "a"), (i32, "b")] i1 $ \[a, b] -> do 30 | c <- f a b 31 | ret c 32 | checkIR ir [text| 33 | define external ccc i1 @func(i32 %a_0, i32 %b_0) { 34 | start: 35 | %0 = icmp $op i32 %a_0, %b_0 36 | ret i1 %0 37 | } 38 | |] 39 | 40 | it "supports 'one-sided if' combinator" $ do 41 | let ir = do 42 | function "func" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> mdo 43 | isZero <- eq a (int32 0) 44 | if' isZero $ do 45 | _ <- add a b 46 | ret $ int32 1000 47 | 48 | ret b 49 | checkIR ir [text| 50 | define external ccc i32 @func(i32 %a_0, i32 %b_0) { 51 | start: 52 | %0 = icmp eq i32 %a_0, 0 53 | br i1 %0, label %if_0, label %end_if_0 54 | if_0: 55 | %1 = add i32 %a_0, %b_0 56 | ret i32 1000 57 | end_if_0: 58 | ret i32 %b_0 59 | } 60 | |] 61 | 62 | it "supports 'loop' combinator" $ do 63 | let ir = do 64 | function "func" [] i32 $ \_ -> mdo 65 | i <- allocate i32 (int32 0) 66 | 67 | loop $ do 68 | iValue <- load i 0 69 | isEqual <- iValue `eq` int32 10 70 | if' isEqual $ do 71 | br end 72 | 73 | end <- blockNamed "end" 74 | ret $ int32 42 75 | checkIR ir [text| 76 | define external ccc i32 @func() { 77 | start: 78 | %stack.ptr_0 = alloca i32 79 | store i32 0, ptr %stack.ptr_0 80 | br label %loop_0 81 | loop_0: 82 | %0 = load i32, ptr %stack.ptr_0 83 | %1 = icmp eq i32 %0, 10 84 | br i1 %1, label %if_0, label %end_if_0 85 | if_0: 86 | br label %end_0 87 | end_if_0: 88 | br label %loop_0 89 | end_0: 90 | ret i32 42 91 | } 92 | |] 93 | 94 | it "supports 'loopWhile' combinator" $ do 95 | let ir = do 96 | function "func" [] i32 $ \_ -> mdo 97 | i <- allocate i32 (int32 10) 98 | let notZero = do 99 | iVal <- load i 0 100 | iVal `ne` int32 0 101 | loopWhile notZero $ do 102 | iVal <- load i 0 103 | iVal' <- sub iVal (int32 1) 104 | store i 0 iVal' 105 | 106 | ret $ int32 42 107 | checkIR ir [text| 108 | define external ccc i32 @func() { 109 | start: 110 | %stack.ptr_0 = alloca i32 111 | store i32 10, ptr %stack.ptr_0 112 | br label %while_begin_0 113 | while_begin_0: 114 | %0 = load i32, ptr %stack.ptr_0 115 | %1 = icmp ne i32 %0, 0 116 | br i1 %1, label %while_body_0, label %while_end_0 117 | while_body_0: 118 | %2 = load i32, ptr %stack.ptr_0 119 | %3 = sub i32 %2, 1 120 | store i32 %3, ptr %stack.ptr_0 121 | br label %while_begin_0 122 | while_end_0: 123 | ret i32 42 124 | } 125 | |] 126 | 127 | it "supports 'loopFor' combinator" $ do 128 | let ir = do 129 | function "func" [] i32 $ \_ -> mdo 130 | x <- allocate i32 (int32 10) 131 | 132 | loopFor (int32 0) (`ult` int32 10) (add (int32 1)) $ \i -> do 133 | xVal <- load x 0 134 | xVal' <- add i xVal 135 | store x 0 xVal' 136 | 137 | ret $ int32 42 138 | checkIR ir [text| 139 | define external ccc i32 @func() { 140 | start: 141 | %stack.ptr_0 = alloca i32 142 | store i32 10, ptr %stack.ptr_0 143 | br label %for_begin_0 144 | for_begin_0: 145 | %0 = phi i32 [0, %start], [%4, %for_body_0] 146 | %1 = icmp ult i32 %0, 10 147 | br i1 %1, label %for_body_0, label %for_end_0 148 | for_body_0: 149 | %2 = load i32, ptr %stack.ptr_0 150 | %3 = add i32 %0, %2 151 | store i32 %3, ptr %stack.ptr_0 152 | %4 = add i32 1, %0 153 | br label %for_begin_0 154 | for_end_0: 155 | ret i32 42 156 | } 157 | |] 158 | 159 | it "supports 'pointer subtraction' combinator" $ do 160 | let ir = do 161 | function "func" [] i32 $ \_ -> mdo 162 | array <- alloca i32 (Just $ int32 5) 0 163 | ptr1 <- gep array [int32 0] 164 | ptr2 <- gep array [int32 3] 165 | _ <- pointerDiff i32 ptr1 ptr2 166 | ret $ int32 42 167 | checkIR ir [text| 168 | define external ccc i32 @func() { 169 | start: 170 | %stack.ptr_0 = alloca i32, i32 5 171 | %0 = getelementptr i32, ptr %stack.ptr_0, i32 0 172 | %1 = getelementptr i32, ptr %stack.ptr_0, i32 3 173 | %2 = ptrtoint ptr %0 to i64 174 | %3 = ptrtoint ptr %1 to i64 175 | %4 = sub i64 %2, %3 176 | %5 = trunc i64 %4 to i32 177 | ret i32 42 178 | } 179 | |] 180 | 181 | it "supports logical not" $ do 182 | let ir = do 183 | function "func" [] i32 $ \_ -> mdo 184 | _ <- not' $ bit 0 185 | ret $ int32 42 186 | checkIR ir [text| 187 | define external ccc i32 @func() { 188 | start: 189 | %0 = select i1 0, i1 0, i1 1 190 | ret i32 42 191 | } 192 | |] 193 | 194 | it "supports computing the minimum of 2 values" $ do 195 | let ir = do 196 | function "func" [] i32 $ \_ -> mdo 197 | _result1 <- minimum' Signed (int32 100) (int32 42) 198 | _result2 <- minimum' Unsigned (int32 100) (int32 42) 199 | ret $ int32 42 200 | checkIR ir [text| 201 | define external ccc i32 @func() { 202 | start: 203 | %0 = icmp slt i32 100, 42 204 | %1 = select i1 %0, i32 100, i32 42 205 | %2 = icmp ult i32 100, 42 206 | %3 = select i1 %2, i32 100, i32 42 207 | ret i32 42 208 | } 209 | |] 210 | 211 | it "supports allocating and initializing a variable on the stack" $ do 212 | let ir = do 213 | function "func" [] i32 $ \_ -> mdo 214 | _i <- allocate i32 (int32 0) 215 | ret $ int32 42 216 | checkIR ir [text| 217 | define external ccc i32 @func() { 218 | start: 219 | %stack.ptr_0 = alloca i32 220 | store i32 0, ptr %stack.ptr_0 221 | ret i32 42 222 | } 223 | |] 224 | 225 | it "supports composing Paths" $ do 226 | let path = mkPath [int32 1, int32 2] ->> mkPath [int32 3] 227 | path `shouldBe` Path [int32 0, int32 1, int32 2, int32 3] 228 | 229 | it "supports computing the address based on a Path" $ do 230 | let path = Path [int32 5] 231 | ir = do 232 | function "func" [] i32 $ \_ -> mdo 233 | array <- alloca i32 (Just $ int32 5) 0 234 | _address <- addr path array 235 | ret $ int32 42 236 | checkIR ir [text| 237 | define external ccc i32 @func() { 238 | start: 239 | %stack.ptr_0 = alloca i32, i32 5 240 | %0 = getelementptr i32, ptr %stack.ptr_0, i32 5 241 | ret i32 42 242 | } 243 | |] 244 | 245 | it "supports dereferencing an address based on a Path" $ do 246 | let path = Path [int32 5] 247 | ir = mdo 248 | function "func" [] i32 $ \_ -> mdo 249 | array <- alloca i32 (Just $ int32 5) 0 250 | _value <- deref path array 251 | ret $ int32 42 252 | checkIR ir [text| 253 | define external ccc i32 @func() { 254 | start: 255 | %stack.ptr_0 = alloca i32, i32 5 256 | %0 = getelementptr i32, ptr %stack.ptr_0, i32 5 257 | %1 = load i32, ptr %0 258 | ret i32 42 259 | } 260 | |] 261 | 262 | it "supports storing a value at an address based on a Path" $ do 263 | let path = Path [int32 5] 264 | ir = mdo 265 | function "func" [] i32 $ \_ -> mdo 266 | array <- alloca i32 (Just $ int32 5) 0 267 | assign path array (int32 1000) 268 | ret $ int32 42 269 | checkIR ir [text| 270 | define external ccc i32 @func() { 271 | start: 272 | %stack.ptr_0 = alloca i32, i32 5 273 | %0 = getelementptr i32, ptr %stack.ptr_0, i32 5 274 | store i32 1000, ptr %0 275 | ret i32 42 276 | } 277 | |] 278 | 279 | it "supports updating a value at an address based on a Path" $ do 280 | let path = Path [int32 5] 281 | ir = mdo 282 | function "func" [] i32 $ \_ -> mdo 283 | array <- alloca i32 (Just $ int32 5) 0 284 | assign path array (int32 1000) 285 | update path array (add (int32 10)) 286 | ret $ int32 42 287 | checkIR ir [text| 288 | define external ccc i32 @func() { 289 | start: 290 | %stack.ptr_0 = alloca i32, i32 5 291 | %0 = getelementptr i32, ptr %stack.ptr_0, i32 5 292 | store i32 1000, ptr %0 293 | %1 = getelementptr i32, ptr %stack.ptr_0, i32 5 294 | %2 = load i32, ptr %1 295 | %3 = add i32 10, %2 296 | store i32 %3, ptr %1 297 | ret i32 42 298 | } 299 | |] 300 | 301 | it "supports incrementing a value at an address based on a Path" $ do 302 | let path = Path [int32 5] 303 | ir = mdo 304 | function "func" [] i32 $ \_ -> mdo 305 | array <- alloca i32 (Just $ int32 5) 0 306 | assign path array (int32 1000) 307 | increment int32 path array 308 | ret $ int32 42 309 | checkIR ir [text| 310 | define external ccc i32 @func() { 311 | start: 312 | %stack.ptr_0 = alloca i32, i32 5 313 | %0 = getelementptr i32, ptr %stack.ptr_0, i32 5 314 | store i32 1000, ptr %0 315 | %1 = getelementptr i32, ptr %stack.ptr_0, i32 5 316 | %2 = load i32, ptr %1 317 | %3 = add i32 1, %2 318 | store i32 %3, ptr %1 319 | ret i32 42 320 | } 321 | |] 322 | 323 | it "supports copying (part of) a type based on a Path" $ do 324 | let path = Path [int32 5] 325 | ir = mdo 326 | function "func" [] i32 $ \_ -> mdo 327 | array <- alloca i32 (Just $ int32 5) 0 328 | assign path array (int32 1000) 329 | array2 <- alloca i32 (Just $ int32 5) 0 330 | copy path array array2 331 | ret $ int32 42 332 | checkIR ir [text| 333 | define external ccc i32 @func() { 334 | start: 335 | %stack.ptr_0 = alloca i32, i32 5 336 | %stack.ptr_1 = alloca i32, i32 5 337 | %0 = getelementptr i32, ptr %stack.ptr_0, i32 5 338 | store i32 1000, ptr %0 339 | %1 = getelementptr i32, ptr %stack.ptr_0, i32 5 340 | %2 = load i32, ptr %1 341 | %3 = getelementptr i32, ptr %stack.ptr_1, i32 5 342 | store i32 %2, ptr %3 343 | ret i32 42 344 | } 345 | |] 346 | 347 | it "supports swapping (part of) a type based on a Path" $ do 348 | let path = Path [int32 5] 349 | ir = mdo 350 | function "func" [] i32 $ \_ -> mdo 351 | array <- alloca i32 (Just $ int32 5) 0 352 | assign path array (int32 1000) 353 | array2 <- alloca i32 (Just $ int32 5) 0 354 | swap path array array2 355 | ret $ int32 42 356 | checkIR ir [text| 357 | define external ccc i32 @func() { 358 | start: 359 | %stack.ptr_0 = alloca i32, i32 5 360 | %stack.ptr_1 = alloca i32, i32 5 361 | %0 = getelementptr i32, ptr %stack.ptr_0, i32 5 362 | store i32 1000, ptr %0 363 | %1 = getelementptr i32, ptr %stack.ptr_0, i32 5 364 | %2 = load i32, ptr %1 365 | %3 = getelementptr i32, ptr %stack.ptr_1, i32 5 366 | %4 = load i32, ptr %3 367 | %5 = getelementptr i32, ptr %stack.ptr_0, i32 5 368 | store i32 %4, ptr %5 369 | %6 = getelementptr i32, ptr %stack.ptr_1, i32 5 370 | store i32 %2, ptr %6 371 | ret i32 42 372 | } 373 | |] 374 | 375 | -------------------------------------------------------------------------------- /tests/test.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-export-lists #-} 2 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 3 | --------------------------------------------------------------------------------