├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── cbits ├── lib.c └── lib.h ├── src ├── Codegen.hs ├── FFI.hs ├── JIT.hs └── Main.hs ├── stack.yaml └── tutorial.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | *.sw[po] 2 | *.o 3 | *.so 4 | cabal.sandbox.config 5 | .cabal-sandbox 6 | dist/ 7 | *.hi 8 | *.o 9 | includes 10 | *.html 11 | *.epub 12 | *.agdai 13 | .stack-work 14 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # NB: don't set `language: haskell` here 2 | 3 | # The following enables several GHC versions to be tested; often it's enough to test only against 4 | # the last release in a major GHC version. Feel free to omit lines listings versions you don't 5 | # need/want testing for. 6 | env: 7 | - CABALVER=1.18 GHCVER=7.6.3 LLVMVER=3.5 8 | - CABALVER=1.18 GHCVER=7.8.4 LLVMVER=3.5 9 | - CABALVER=1.22 GHCVER=7.10.1 LLVMVER=3.5 10 | - CABALVER=1.22 GHCVER=7.10.2 LLVMVER=3.5 11 | # - CABALVER=head GHCVER=head # see section about GHC HEAD snapshots 12 | 13 | # Note: the distinction between `before_install` and `install` is not important. 14 | before_install: 15 | - travis_retry sudo apt-get purge -y -qq libllvm3.4 llvm-3.4 16 | - travis_retry sudo add-apt-repository -y ppa:hvr/ghc 17 | - travis_retry sudo apt-get update 18 | - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER # see note about happy/alex 19 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH:$HOME/.cabal/bin:$PATH 20 | - | 21 | if [ $GHCVER = "head" ] || [ ${GHCVER%.*} = "7.8" ] || [ ${GHCVER%.*} = "7.10" ]; then 22 | travis_retry sudo apt-get install happy-1.19.4 alex-3.1.3 23 | export PATH=/opt/alex/3.1.3/bin:/opt/happy/1.19.4/bin:$PATH 24 | else 25 | travis_retry sudo apt-get install happy alex 26 | fi 27 | 28 | # update gcc and g++ 29 | - gcc --version 30 | - g++ --version 31 | - sudo add-apt-repository -y ppa:ubuntu-toolchain-r/test 32 | - sudo apt-get update -qq 33 | - sudo apt-get install -qq g++-4.8 gcc-4.8 34 | - gcc --version 35 | - g++ --version 36 | - sudo update-alternatives --install /usr/bin/gcc gcc /usr/bin/gcc-4.8 90 37 | - sudo update-alternatives --install /usr/bin/g++ g++ /usr/bin/g++-4.8 90 38 | - gcc --version 39 | - g++ --version 40 | 41 | # update llvm 42 | - wget -O - http://llvm.org/apt/llvm-snapshot.gpg.key|sudo apt-key add - 43 | - travis_retry sudo add-apt-repository "deb http://llvm.org/apt/precise/ llvm-toolchain-precise main" 44 | - travis_retry sudo add-apt-repository "deb http://llvm.org/apt/precise/ llvm-toolchain-precise-$LLVMVER main" 45 | - travis_retry sudo apt-get update 46 | - sudo apt-get install libedit-dev -y 47 | - sudo apt-get install -y llvm-$LLVMVER llvm-$LLVMVER-dev 48 | #- sudo ln -s /usr/bin/opt-$LLVMVER /usr/bin/opt 49 | - export PATH="/usr/bin:$PATH" 50 | 51 | install: 52 | - cabal --version 53 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 54 | - travis_retry cabal update 55 | - travis_retry cabal install -j4 --only-dependencies 56 | 57 | # Here starts the actual work to be performed for the package under test; any command which exits 58 | # with a non-zero exit code causes the build to fail. 59 | script: 60 | - cabal install 61 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014-2017, Stephen Diehl 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to 5 | deal in the Software without restriction, including without limitation the 6 | rights to use, copy, modify, merge, publish, distribute, sublicense, and/or 7 | sell copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 18 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 19 | IN THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | llvm-tutorial-standalone 2 | ------------------------ 3 | 4 | **DEPRECATED**. Use: https://github.com/llvm-hs/llvm-hs-kaleidoscope 5 | -------------------------------------------------------------------------------- /cbits/lib.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | void myfunc(int count) { 4 | int i; 5 | for (i = 0; i < count; i++) { 6 | printf("Hello Haskell\n"); 7 | } 8 | } 9 | -------------------------------------------------------------------------------- /cbits/lib.h: -------------------------------------------------------------------------------- 1 | void myfunc(int count); 2 | -------------------------------------------------------------------------------- /src/Codegen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | 4 | module Codegen where 5 | 6 | import Data.Word 7 | import Data.String 8 | import Data.List 9 | import Data.Function 10 | import qualified Data.Map as Map 11 | 12 | import Control.Applicative 13 | import Control.Monad.State 14 | 15 | import LLVM.General.AST 16 | import LLVM.General.AST.Type 17 | import LLVM.General.AST.Global 18 | import qualified LLVM.General.AST as AST 19 | 20 | import qualified LLVM.General.AST.Linkage as L 21 | import qualified LLVM.General.AST.Constant as C 22 | import qualified LLVM.General.AST.Attribute as A 23 | import qualified LLVM.General.AST.CallingConvention as CC 24 | import qualified LLVM.General.AST.FloatingPointPredicate as FP 25 | 26 | ------------------------------------------------------------------------------- 27 | -- Module Level 28 | ------------------------------------------------------------------------------- 29 | 30 | newtype LLVM a = LLVM (State AST.Module a) 31 | deriving (Functor, Applicative, Monad, MonadState AST.Module ) 32 | 33 | runLLVM :: AST.Module -> LLVM a -> AST.Module 34 | runLLVM mod (LLVM m) = execState m mod 35 | 36 | emptyModule :: String -> AST.Module 37 | emptyModule label = defaultModule { moduleName = label } 38 | 39 | addDefn :: Definition -> LLVM () 40 | addDefn d = do 41 | defs <- gets moduleDefinitions 42 | modify $ \s -> s { moduleDefinitions = defs ++ [d] } 43 | 44 | define :: Type -> String -> [(Type, Name)] -> Codegen a -> LLVM () 45 | define retty label argtys body = addDefn $ 46 | GlobalDefinition $ functionDefaults { 47 | name = Name label 48 | , parameters = ([Parameter ty nm [] | (ty, nm) <- argtys], False) 49 | , returnType = retty 50 | , basicBlocks = bls 51 | } 52 | where 53 | bls = createBlocks $ execCodegen $ do 54 | enter <- addBlock entryBlockName 55 | _ <- setBlock enter 56 | body 57 | 58 | external :: Type -> String -> [(Type, Name)] -> LLVM () 59 | external retty label argtys = addDefn $ 60 | GlobalDefinition $ functionDefaults { 61 | name = Name label 62 | , linkage = L.External 63 | , parameters = ([Parameter ty nm [] | (ty, nm) <- argtys], False) 64 | , returnType = retty 65 | , basicBlocks = [] 66 | } 67 | 68 | --------------------------------------------------------------------------------- 69 | -- Types 70 | ------------------------------------------------------------------------------- 71 | 72 | -- IEEE 754 double 73 | double :: Type 74 | double = FloatingPointType 64 IEEE 75 | 76 | void :: Type 77 | void = AST.VoidType 78 | 79 | ------------------------------------------------------------------------------- 80 | -- Names 81 | ------------------------------------------------------------------------------- 82 | 83 | type Names = Map.Map String Int 84 | 85 | uniqueName :: String -> Names -> (String, Names) 86 | uniqueName nm ns = 87 | case Map.lookup nm ns of 88 | Nothing -> (nm, Map.insert nm 1 ns) 89 | Just ix -> (nm ++ show ix, Map.insert nm (ix+1) ns) 90 | 91 | instance IsString Name where 92 | fromString = Name . fromString 93 | 94 | ------------------------------------------------------------------------------- 95 | -- Codegen State 96 | ------------------------------------------------------------------------------- 97 | 98 | type SymbolTable = [(String, Operand)] 99 | 100 | data CodegenState 101 | = CodegenState { 102 | currentBlock :: Name -- Name of the active block to append to 103 | , blocks :: Map.Map Name BlockState -- Blocks for function 104 | , symtab :: SymbolTable -- Function scope symbol table 105 | , blockCount :: Int -- Count of basic blocks 106 | , count :: Word -- Count of unnamed instructions 107 | , names :: Names -- Name Supply 108 | } deriving Show 109 | 110 | data BlockState 111 | = BlockState { 112 | idx :: Int -- Block index 113 | , stack :: [Named Instruction] -- Stack of instructions 114 | , term :: Maybe (Named Terminator) -- Block terminator 115 | } deriving Show 116 | 117 | ------------------------------------------------------------------------------- 118 | -- Codegen Operations 119 | ------------------------------------------------------------------------------- 120 | 121 | newtype Codegen a = Codegen { runCodegen :: State CodegenState a } 122 | deriving (Functor, Applicative, Monad, MonadState CodegenState ) 123 | 124 | sortBlocks :: [(Name, BlockState)] -> [(Name, BlockState)] 125 | sortBlocks = sortBy (compare `on` (idx . snd)) 126 | 127 | createBlocks :: CodegenState -> [BasicBlock] 128 | createBlocks m = map makeBlock $ sortBlocks $ Map.toList (blocks m) 129 | 130 | makeBlock :: (Name, BlockState) -> BasicBlock 131 | makeBlock (l, (BlockState _ s t)) = BasicBlock l s (maketerm t) 132 | where 133 | maketerm (Just x) = x 134 | maketerm Nothing = error $ "Block has no terminator: " ++ (show l) 135 | 136 | entryBlockName :: String 137 | entryBlockName = "entry" 138 | 139 | emptyBlock :: Int -> BlockState 140 | emptyBlock i = BlockState i [] Nothing 141 | 142 | emptyCodegen :: CodegenState 143 | emptyCodegen = CodegenState (Name entryBlockName) Map.empty [] 1 0 Map.empty 144 | 145 | execCodegen :: Codegen a -> CodegenState 146 | execCodegen m = execState (runCodegen m) emptyCodegen 147 | 148 | fresh :: Codegen Word 149 | fresh = do 150 | i <- gets count 151 | modify $ \s -> s { count = 1 + i } 152 | return $ i + 1 153 | 154 | instr :: Type -> Instruction -> Codegen (Operand) 155 | instr ty ins = do 156 | n <- fresh 157 | let ref = (UnName n) 158 | blk <- current 159 | let i = stack blk 160 | modifyBlock (blk { stack = i ++ [ref := ins] } ) 161 | return $ local ty ref 162 | 163 | terminator :: Named Terminator -> Codegen (Named Terminator) 164 | terminator trm = do 165 | blk <- current 166 | modifyBlock (blk { term = Just trm }) 167 | return trm 168 | 169 | ------------------------------------------------------------------------------- 170 | -- Block Stack 171 | ------------------------------------------------------------------------------- 172 | 173 | entry :: Codegen Name 174 | entry = gets currentBlock 175 | 176 | addBlock :: String -> Codegen Name 177 | addBlock bname = do 178 | bls <- gets blocks 179 | ix <- gets blockCount 180 | nms <- gets names 181 | let new = emptyBlock ix 182 | (qname, supply) = uniqueName bname nms 183 | modify $ \s -> s { blocks = Map.insert (Name qname) new bls 184 | , blockCount = ix + 1 185 | , names = supply 186 | } 187 | return (Name qname) 188 | 189 | setBlock :: Name -> Codegen Name 190 | setBlock bname = do 191 | modify $ \s -> s { currentBlock = bname } 192 | return bname 193 | 194 | getBlock :: Codegen Name 195 | getBlock = gets currentBlock 196 | 197 | modifyBlock :: BlockState -> Codegen () 198 | modifyBlock new = do 199 | active <- gets currentBlock 200 | modify $ \s -> s { blocks = Map.insert active new (blocks s) } 201 | 202 | current :: Codegen BlockState 203 | current = do 204 | c <- gets currentBlock 205 | blks <- gets blocks 206 | case Map.lookup c blks of 207 | Just x -> return x 208 | Nothing -> error $ "No such block: " ++ show c 209 | 210 | ------------------------------------------------------------------------------- 211 | -- Symbol Table 212 | ------------------------------------------------------------------------------- 213 | 214 | assign :: String -> Operand -> Codegen () 215 | assign var x = do 216 | lcls <- gets symtab 217 | modify $ \s -> s { symtab = [(var, x)] ++ lcls } 218 | 219 | getvar :: String -> Codegen Operand 220 | getvar var = do 221 | syms <- gets symtab 222 | case lookup var syms of 223 | Just x -> return x 224 | Nothing -> error $ "Local variable not in scope: " ++ show var 225 | 226 | ------------------------------------------------------------------------------- 227 | 228 | -- References 229 | local :: Type -> Name -> Operand 230 | local = LocalReference 231 | 232 | global :: Type -> Name -> C.Constant 233 | global = C.GlobalReference 234 | 235 | externf :: Type -> Name -> Operand 236 | externf ty nm = ConstantOperand (C.GlobalReference ty nm) 237 | 238 | -- Arithmetic and Constants 239 | fadd :: Operand -> Operand -> Codegen Operand 240 | fadd a b = instr float $ FAdd NoFastMathFlags a b [] 241 | 242 | fsub :: Operand -> Operand -> Codegen Operand 243 | fsub a b = instr float $ FSub NoFastMathFlags a b [] 244 | 245 | fmul :: Operand -> Operand -> Codegen Operand 246 | fmul a b = instr float $ FMul NoFastMathFlags a b [] 247 | 248 | fdiv :: Operand -> Operand -> Codegen Operand 249 | fdiv a b = instr float $ FDiv NoFastMathFlags a b [] 250 | 251 | fcmp :: FP.FloatingPointPredicate -> Operand -> Operand -> Codegen Operand 252 | fcmp cond a b = instr float $ FCmp cond a b [] 253 | 254 | cons :: C.Constant -> Operand 255 | cons = ConstantOperand 256 | 257 | uitofp :: Type -> Operand -> Codegen Operand 258 | uitofp ty a = instr float $ UIToFP a ty [] 259 | 260 | toArgs :: [Operand] -> [(Operand, [A.ParameterAttribute])] 261 | toArgs = map (\x -> (x, [])) 262 | 263 | -- Effects 264 | call :: Operand -> [Operand] -> Codegen Operand 265 | call fn args = instr float $ Call Nothing CC.C [] (Right fn) (toArgs args) [] [] 266 | 267 | alloca :: Type -> Codegen Operand 268 | alloca ty = instr float $ Alloca ty Nothing 0 [] 269 | 270 | store :: Operand -> Operand -> Codegen Operand 271 | store ptr val = instr float $ Store False ptr val Nothing 0 [] 272 | 273 | load :: Operand -> Codegen Operand 274 | load ptr = instr float $ Load False ptr Nothing 0 [] 275 | 276 | -- Control Flow 277 | br :: Name -> Codegen (Named Terminator) 278 | br val = terminator $ Do $ Br val [] 279 | 280 | cbr :: Operand -> Name -> Name -> Codegen (Named Terminator) 281 | cbr cond tr fl = terminator $ Do $ CondBr cond tr fl [] 282 | 283 | phi :: Type -> [(Operand, Name)] -> Codegen Operand 284 | phi ty incoming = instr float $ Phi ty incoming [] 285 | 286 | ret :: Operand -> Codegen (Named Terminator) 287 | ret val = terminator $ Do $ Ret (Just val) [] 288 | 289 | retvoid :: Codegen (Named Terminator) 290 | retvoid = terminator $ Do $ Ret Nothing [] 291 | -------------------------------------------------------------------------------- /src/FFI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | 4 | import JIT 5 | import Codegen 6 | import qualified LLVM.General.AST as AST 7 | import qualified LLVM.General.AST.Float as F 8 | import qualified LLVM.General.AST.Constant as C 9 | 10 | import Foreign.C.Types 11 | 12 | {- 13 | 14 | ; ModuleID = 'my cool jit' 15 | 16 | declare void @myfunc(i64) 17 | 18 | define void @main() { 19 | entry: 20 | call void @myfunc(i64 5) 21 | ret void 22 | } 23 | 24 | -} 25 | 26 | foreign import ccall safe "myfunc" myfunc 27 | :: CInt -> IO () 28 | 29 | initModule :: AST.Module 30 | initModule = emptyModule "my cool jit" 31 | 32 | example :: LLVM () 33 | example = do 34 | external void "myfunc" [(AST.IntegerType 64, "count")] 35 | define void "main" [] $ do 36 | let a = cons $ C.Int 64 5 37 | call (externf AST.VoidType "myfunc") [a] 38 | retvoid 39 | 40 | main :: IO AST.Module 41 | main = do 42 | let ast = runLLVM initModule example 43 | rc <- runJIT ast 44 | return ast 45 | -------------------------------------------------------------------------------- /src/JIT.hs: -------------------------------------------------------------------------------- 1 | module JIT where 2 | 3 | import Data.Int 4 | import Data.Word 5 | import Foreign.Ptr ( FunPtr, castFunPtr ) 6 | 7 | import Control.Monad.Except 8 | 9 | import LLVM.General.Target 10 | import LLVM.General.Context 11 | import LLVM.General.CodeModel 12 | import LLVM.General.Module as Mod 13 | import qualified LLVM.General.AST as AST 14 | 15 | import LLVM.General.PassManager 16 | import LLVM.General.Transforms 17 | import LLVM.General.Analysis 18 | 19 | import qualified LLVM.General.ExecutionEngine as EE 20 | 21 | foreign import ccall "dynamic" haskFun :: FunPtr (IO Double) -> (IO Double) 22 | 23 | run :: FunPtr a -> IO Double 24 | run fn = haskFun (castFunPtr fn :: FunPtr (IO Double)) 25 | 26 | jit :: Context -> (EE.MCJIT -> IO a) -> IO a 27 | jit c = EE.withMCJIT c optlevel model ptrelim fastins 28 | where 29 | optlevel = Just 0 -- optimization level 30 | model = Nothing -- code model ( Default ) 31 | ptrelim = Nothing -- frame pointer elimination 32 | fastins = Nothing -- fast instruction selection 33 | 34 | passes :: PassSetSpec 35 | passes = defaultCuratedPassSetSpec { optLevel = Just 3 } 36 | 37 | runJIT :: AST.Module -> IO (Either String AST.Module) 38 | runJIT mod = do 39 | withContext $ \context -> 40 | jit context $ \executionEngine -> 41 | runExceptT $ withModuleFromAST context mod $ \m -> 42 | withPassManager passes $ \pm -> do 43 | -- Optimization Pass 44 | {-runPassManager pm m-} 45 | optmod <- moduleAST m 46 | s <- moduleLLVMAssembly m 47 | putStrLn s 48 | 49 | EE.withModuleInEngine executionEngine m $ \ee -> do 50 | mainfn <- EE.getFunction ee (AST.Name "main") 51 | case mainfn of 52 | Just fn -> do 53 | res <- run fn 54 | putStrLn $ "Evaluated to: " ++ show res 55 | Nothing -> return () 56 | 57 | -- Return the optimized module 58 | return optmod 59 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | import JIT 2 | import Codegen 3 | import qualified LLVM.General.AST as AST 4 | import qualified LLVM.General.AST.Float as F 5 | import qualified LLVM.General.AST.Constant as C 6 | 7 | {- 8 | 9 | ; ModuleID = 'my cool jit' 10 | 11 | define double @main() { 12 | entry: 13 | %1 = fadd double 1.000000e+01, 2.000000e+01 14 | ret double %1 15 | } 16 | 17 | -} 18 | 19 | initModule :: AST.Module 20 | initModule = emptyModule "my cool jit" 21 | 22 | logic :: LLVM () 23 | logic = do 24 | define double "main" [] $ do 25 | let a = cons $ C.Float (F.Double 10) 26 | let b = cons $ C.Float (F.Double 20) 27 | res <- fadd a b 28 | ret res 29 | 30 | main :: IO AST.Module 31 | main = do 32 | let ast = runLLVM initModule logic 33 | rc <- runJIT ast 34 | return ast 35 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.8 2 | packages: 3 | - '.' 4 | - location: 5 | git: https://github.com/bscarlet/llvm-general.git 6 | commit: 529f9bf117b5ffd1ccf7ebeb679a97b3b1c67938 # 3.8 7 | # commit: ec1ad5bd2112e7f64dbb43441b5e2075cf6ad8e7 # 3.9 8 | extra-dep: true 9 | subdirs: 10 | - 'llvm-general' 11 | - 'llvm-general-pure' 12 | 13 | flags: 14 | llvm-general: 15 | shared-llvm: true 16 | -------------------------------------------------------------------------------- /tutorial.cabal: -------------------------------------------------------------------------------- 1 | name: tutorial 2 | version: 0.2.0.0 3 | synopsis: Standalone LLVM JIT Tutorial 4 | license: MIT 5 | category: Compilers 6 | description: 7 | synopsis: 8 | license-file: LICENSE 9 | author: Stephen Diehl 10 | maintainer: stephen.m.diehl@gmail.com 11 | build-type: Simple 12 | extra-source-files: README.md 13 | cabal-version: >=1.10 14 | 15 | executable main 16 | build-depends: 17 | base >= 4.6 && <4.10, 18 | mtl >= 2.2, 19 | containers >= 0.5, 20 | 21 | llvm-general == 3.8.*, 22 | llvm-general-pure == 3.8.* 23 | 24 | other-modules: 25 | Codegen 26 | JIT 27 | 28 | default-language: Haskell2010 29 | hs-source-dirs: src 30 | main-is: Main.hs 31 | 32 | Include-dirs: cbits 33 | C-sources: 34 | cbits/lib.c 35 | --------------------------------------------------------------------------------