├── .github └── workflows │ └── ci.yml ├── .gitignore ├── ChangeLog.md ├── Dockerfile ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── finish-testing ├── build.sh └── test.ll ├── hang.tl ├── justfile ├── odd-perfect.tl ├── package.yaml ├── runtime.c ├── simple.tl ├── src ├── ANorm.hs ├── CmdLine.hs ├── CmdLineArgs.hs ├── CodegenMonad.hs ├── Fresh.hs ├── HighLevel.hs ├── Infer.hs ├── LowLevel.hs ├── ParseLisp.hs ├── Parsing.hs ├── Pretty.hs ├── RuntimeDefs.hs ├── Scope.hs └── Types.hs ├── stack.yaml ├── stack.yaml.lock ├── test ├── ANormSpec.hs ├── ExecutionSpec.hs ├── LLSpec.hs ├── ParseLispSpec.hs ├── RuntimeSpec.hs ├── Spec.hs └── golden │ ├── add.gold │ ├── add.tl │ ├── arith.gold │ ├── arith.tl │ ├── closure.gold │ ├── closure.tl │ ├── fact.gold │ ├── fact.tl │ ├── if_simple.gold │ ├── if_simple.tl │ ├── if_tail.gold │ ├── if_tail.tl │ ├── if_tail_nested.gold │ ├── if_tail_nested.tl │ ├── lambda_double_nest.gold │ ├── lambda_double_nest.tl │ ├── let.gold │ ├── let.tl │ ├── letrec.gold │ ├── letrec.tl │ ├── mutual_rec.gold │ ├── mutual_rec.tl │ ├── nested_lambda.gold │ ├── nested_lambda.tl │ ├── tail.gold │ └── tail.tl └── tutorial.pdf /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: Build 2 | 3 | on: [push] 4 | 5 | jobs: 6 | build: 7 | 8 | runs-on: ubuntu-latest 9 | 10 | steps: 11 | - name: Checkout 12 | uses: actions/checkout@v3 13 | 14 | - name: Install Packages 15 | run: | 16 | # get system packages 17 | set -euxo pipefail 18 | export DEBIAN_FRONTEND=noninteractive 19 | sudo apt-get update -q 20 | sudo apt-get install -yq llvm-15-dev clang-15 21 | # make sure we have llvm binaries on the path 22 | echo "/usr/lib/llvm-15/bin" >> $GITHUB_PATH 23 | 24 | # install just 25 | sudo snap install --edge --classic just 26 | 27 | - name: Verify package install 28 | run: | 29 | set -euxo pipefail 30 | ls -la $(which llvm-config-15) 31 | llvm-config --version 32 | clang --version 33 | 34 | - name: Cache Global Stack 35 | uses: actions/cache@v3 36 | with: 37 | path: ~/.stack/ 38 | key: stack-global-${{ hashFiles('package.yaml') }}-${{ hashFiles('stack.yaml.lock') }} 39 | restore-keys: stack-global 40 | 41 | - name: Install Dependencies 42 | run: just install-dev-deps 43 | 44 | - name: Build 45 | run: just build 46 | 47 | - name: Test 48 | run: just test 49 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | llvm-lambda.cabal 20 | .HTF/ 21 | *~ 22 | 23 | # Ignore all generated files 24 | *.o 25 | *.s 26 | *.out 27 | gen.* 28 | gen-opt.* 29 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for llvm-lambda 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM fpco/stack-build:lts-9 2 | 3 | RUN apt-get update && apt-get install -y llvm-5.0-dev clang-5.0 4 | RUN ln -s /usr/bin/clang-5.0 /usr/bin/clang 5 | 6 | WORKDIR /root/llvm-lambda 7 | 8 | ADD stack.yaml . 9 | ADD package.yaml . 10 | RUN stack --no-terminal --install-ghc test --bench --only-dependencies 11 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 Tobin Yehle 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![Build](https://github.com/tyehle/llvm-lambda/workflows/Build/badge.svg?branch=master) 2 | 3 | # llvm-lambda 4 | A compiler for a small language with lambda functions using llvm. 5 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Options.Applicative 4 | 5 | import CmdLine (writeOutput) 6 | import CmdLineArgs (argParser) 7 | 8 | 9 | main :: IO () 10 | main = execParser parserInfo >>= writeOutput 11 | where 12 | parserInfo = info (argParser <**> helper) 13 | ( fullDesc 14 | <> header "tlc - Compiler for a tiny language" 15 | ) 16 | -------------------------------------------------------------------------------- /finish-testing/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # llc -filetype=obj -O2 test.ll && clang test.o -o test.out 4 | 5 | llc test.ll 6 | as test.s -o test.o 7 | ld -o test.out -dynamic-linker=/lib64/ld-linux-x86-64.so.2 /usr/lib/x86_64-linux-gnu/crt1.o /usr/lib/x86_64-linux-gnu/crti.o test.o -lc /usr/lib/x86_64-linux-gnu/crtn.o 8 | -------------------------------------------------------------------------------- /finish-testing/test.ll: -------------------------------------------------------------------------------- 1 | declare i32 @putchar(i32) 2 | 3 | define void @main() { 4 | call i32 @putchar(i32 33) 5 | call i32 @putchar(i32 10) 6 | ret void 7 | } 8 | -------------------------------------------------------------------------------- /hang.tl: -------------------------------------------------------------------------------- 1 | (letrec [u u] u) 2 | -------------------------------------------------------------------------------- /justfile: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env just --justfile 2 | 3 | build: 4 | stack build --test --no-run-tests 5 | 6 | install-dev-deps: 7 | stack --install-ghc test --only-dependencies 8 | # stack build hlint 9 | 10 | @run: 11 | # to link without clang: 12 | # ld -dynamic-linker /lib64/ld-linux-x86-64.so.2 /usr/lib/x86_64-linux-gnu/crt1.o /usr/lib/x86_64-linux-gnu/crti.o -lc gen.o /usr/lib/x86_64-linux-gnu/crtn.o 13 | # stack run -- --format=llvm "$@" > gen.ll \ 14 | # && opt -S -O3 gen.ll > gen-opt.ll \ 15 | # && llc -filetype=obj -O3 gen-opt.ll \ 16 | # && clang -o gen.out -flto -O3 gen-opt.o runtime.o \ 17 | # && ./gen.out 18 | stack run -- -O3 "$@" 19 | 20 | test: build 21 | stack test 22 | 23 | lint: 24 | stack exec hlint -- app src test 25 | 26 | check: test lint 27 | 28 | push: check 29 | # don't push to master 30 | # ! git branch | grep '* master' 31 | git push 32 | 33 | # Development 34 | 35 | ghcid: 36 | stack exec -- ghcid --command='stack ghci --pedantic' 37 | 38 | interactive-test: 39 | stack exec -- ghcid --run --clear --no-height-limit --command='stack ghci --test --main-is=llvm-lambda:test:llvm-lambda-test' --setup=':set args --hide-successes --color=always' 40 | 41 | -------------------------------------------------------------------------------- /odd-perfect.tl: -------------------------------------------------------------------------------- 1 | ; Find the first odd perfect number 2 | 3 | (let [mod (lambda (n m) (- n (* (/ n m) m)))] 4 | (let [aliquot-sum (lambda (n) 5 | (letrec [go (lambda (total i) 6 | (if0 i 7 | total 8 | (if0 (mod n i) 9 | (go (+ total i) (- i 1)) 10 | (go total (- i 1)))))] 11 | (go 0 (- n 1))))] 12 | (letrec [first-odd-perfect (lambda (n) 13 | (if0 (- n (aliquot-sum n)) 14 | n 15 | (first-odd-perfect (+ n 2))))] 16 | (first-odd-perfect 1)))) 17 | 18 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: llvm-lambda 2 | version: 0.1.0.0 3 | github: "tyehle/llvm-lambda" 4 | license: BSD3 5 | author: "Tobin Yehle" 6 | maintainer: "tobinyehle@gmail.com" 7 | copyright: "2018 Tobin Yehle" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on Github at 21 | 22 | dependencies: 23 | - base 24 | - bytestring 25 | - containers 26 | - directory 27 | - filepath 28 | - llvm-hs 29 | #- llvm-hs-pretty 30 | - llvm-hs-pure 31 | - megaparsec 32 | - mtl 33 | - optparse-applicative 34 | - process 35 | - text 36 | - transformers 37 | - utf8-string 38 | 39 | library: 40 | source-dirs: src 41 | dependencies: [] 42 | 43 | executables: 44 | tlc: 45 | main: Main.hs 46 | source-dirs: app 47 | ghc-options: 48 | - -threaded 49 | - -rtsopts 50 | - -with-rtsopts=-N 51 | - -Wno-deprecations 52 | dependencies: 53 | - llvm-lambda 54 | 55 | tests: 56 | llvm-lambda-test: 57 | main: Spec.hs 58 | source-dirs: test 59 | ghc-options: 60 | - -threaded 61 | - -rtsopts 62 | - -with-rtsopts=-N 63 | dependencies: 64 | - llvm-lambda 65 | - regex-pcre-builtin 66 | - tasty 67 | - tasty-hunit 68 | - tasty-golden 69 | - raw-strings-qq 70 | - utf8-string 71 | -------------------------------------------------------------------------------- /runtime.c: -------------------------------------------------------------------------------- 1 | #include "stdint.h" 2 | #include "stdio.h" 3 | #include "stdlib.h" 4 | 5 | 6 | typedef struct __layout { 7 | uint16_t gc_flags; 8 | uint16_t size; 9 | uint16_t num_pointers; 10 | uint16_t placeholder; // put the sum type tag in here? 11 | } __layout; 12 | 13 | 14 | typedef struct __heap_object { 15 | struct __heap_object* object_link; 16 | __layout layout; 17 | } __heap_object; 18 | 19 | 20 | typedef struct __scope_cell { 21 | struct __heap_object* object; 22 | struct __scope_cell* prev; 23 | } __scope_cell; 24 | 25 | 26 | #define ALIVE 1 27 | __heap_object* __all_objects = 0; 28 | uint64_t __num_objects = 0; 29 | extern __scope_cell* __in_scope; 30 | 31 | 32 | void __run_gc(); 33 | void __print_object(__heap_object* obj); 34 | void __print_scope(); 35 | 36 | 37 | __heap_object* __allocate(size_t num_bytes) { 38 | unsigned long header_size = sizeof(__heap_object); 39 | unsigned long size = header_size + num_bytes; 40 | 41 | if(num_bytes % 8 != 0) { 42 | printf("Only allocate a whole number of words\n"); 43 | exit(1); 44 | } 45 | 46 | __heap_object* obj = malloc(size); 47 | 48 | // periodically run the GC 49 | if(__num_objects % 16 == 15) { 50 | __run_gc(); 51 | } 52 | 53 | #if defined(DEBUG) 54 | printf("Allocated %lu bytes at 0x%lx\n", size, (long)obj); 55 | #endif 56 | 57 | if(obj == 0) { 58 | // we are probably out of memory 59 | // try to free some :fingers_crossed: 60 | __run_gc(); 61 | obj = malloc(size); 62 | if(obj == 0) { 63 | printf("Out of memory\n"); 64 | exit(1); 65 | } 66 | } 67 | 68 | __num_objects += 1; 69 | obj->object_link = __all_objects; 70 | __all_objects = obj; 71 | 72 | obj->layout.gc_flags = 0; 73 | obj->layout.num_pointers = 0; 74 | obj->layout.size = num_bytes / 8; 75 | 76 | return obj; 77 | } 78 | 79 | 80 | void __mark_heap_objects(__heap_object* obj) { 81 | #if defined(DEBUG) 82 | printf("Marking 0x%lx\n", (long)obj); 83 | printf( 84 | " metadata: %04x|%04x|%04x\n", 85 | obj->layout.gc_flags, 86 | obj->layout.size, 87 | obj->layout.num_pointers 88 | ); 89 | #endif 90 | 91 | // allow recursive data structures 92 | if(obj->layout.gc_flags & ALIVE) { 93 | // we have already seen this object 94 | #if defined(DEBUG) 95 | printf("Already marked\n"); 96 | #endif 97 | return; 98 | } 99 | 100 | // mark this object as visited 101 | obj->layout.gc_flags |= ALIVE; 102 | 103 | #if defined(DEBUG) 104 | printf("%d environment pointers\n", obj->layout.num_pointers); 105 | #endif 106 | __heap_object** pointer_array = (__heap_object**)(&obj[1]); 107 | for(uint16_t i = 0; i < obj->layout.num_pointers; i++) { 108 | __mark_heap_objects(pointer_array[i]); 109 | } 110 | } 111 | 112 | 113 | void __run_gc() { 114 | #if defined(DEBUG) 115 | printf("============================= Running GC =============================\n"); 116 | printf("current scope: "); 117 | __print_scope(); 118 | printf("\n"); 119 | #endif 120 | 121 | // Mark all visible objects 122 | __scope_cell* current_scope; 123 | current_scope = __in_scope; 124 | while(current_scope != 0) { 125 | #if defined(DEBUG) 126 | printf("Marking object in scope 0x%lx\n", (long)current_scope); 127 | #endif 128 | __mark_heap_objects(current_scope->object); 129 | current_scope = current_scope->prev; 130 | } 131 | 132 | // free everything that wasn't marked 133 | __heap_object* previous = 0; 134 | __heap_object* current = __all_objects; 135 | while(current != 0) { 136 | if(current->layout.gc_flags & ALIVE) { 137 | // this object has been marked 138 | // remove the tag 139 | current->layout.gc_flags &= ~ALIVE; 140 | // move on to the next item 141 | previous = current; 142 | current = current->object_link; 143 | } else { 144 | // delete the object 145 | #if defined(DEBUG) 146 | printf("Freeing "); 147 | __print_object(current); 148 | #endif 149 | // remove the item from the object list 150 | __num_objects -= 1; 151 | __heap_object* next = current->object_link; 152 | if(previous == 0) { 153 | __all_objects = next; 154 | } else { 155 | previous->object_link = next; 156 | } 157 | free(current); 158 | current = next; 159 | } 160 | } 161 | 162 | #if defined(DEBUG) 163 | printf("---------------------------- GC Complete -----------------------------\n"); 164 | #endif 165 | } 166 | 167 | 168 | __attribute__((noinline)) 169 | void __print_object(__heap_object* obj) { 170 | uint16_t size = obj->layout.size; 171 | 172 | printf( 173 | "obj@0x%lx<0x%lx,%04x|%04x|%04x>[", 174 | (long)obj, 175 | (long)obj->object_link, 176 | obj->layout.gc_flags, 177 | size, 178 | obj->layout.num_pointers 179 | ); 180 | 181 | void** values = (void**)(&obj[1]); 182 | 183 | for(uint16_t i = 0; i < size - 1; i++) { 184 | printf("0x%lx,", (long) values[i]); 185 | } 186 | printf("0x%lx]\n", (long) values[size - 1]); 187 | } 188 | 189 | 190 | __attribute__((noinline)) 191 | void __print_scope() { 192 | __scope_cell* current = __in_scope; 193 | if(current == 0) { 194 | puts("[]"); 195 | return; 196 | } 197 | printf("[0x%lx", (long) current->object); 198 | current = current->prev; 199 | while(current != 0) { 200 | printf(",0x%lx", (long) current->object); 201 | current = current->prev; 202 | } 203 | puts("]"); 204 | } 205 | 206 | 207 | // int main() { 208 | // __heap_object* a = __create_closure((void*)0xdeadbeef, 3, 1, 1); 209 | // __heap_object* b = __create_closure((void*)0x12345678, 4, 1, 1); 210 | // __heap_object* c = __create_closure((void*)0x12345678, 5, 0, 0); 211 | // __heap_object* d = __create_closure((void*)0x12345678, 6, 1, 1); 212 | // __heap_object* e = __create_closure((void*)0x12345678, 7, 0, 0); 213 | 214 | // __set_object_slot(a, 0, b); 215 | // __set_object_slot(b, 0, c); 216 | // __set_object_slot(d, 0, e); 217 | 218 | // __push_scope(a); 219 | 220 | // __run_gc(); 221 | 222 | // __check_arity(a, 2); 223 | 224 | // return 0; 225 | // } 226 | -------------------------------------------------------------------------------- /simple.tl: -------------------------------------------------------------------------------- 1 | (letrec (f (lambda (n) 2 | (if0 n 3 | 0 4 | (f (- n 1))))) 5 | (f 175000)) 6 | -------------------------------------------------------------------------------- /src/ANorm.hs: -------------------------------------------------------------------------------- 1 | module ANorm where 2 | 3 | import Control.Monad (zipWithM) 4 | 5 | import Fresh 6 | import qualified LowLevel as LL 7 | 8 | data Prog = Prog [Def] Expr deriving (Eq, Show) 9 | 10 | data Def = ClosureDef String String [String] Expr deriving (Eq, Show) 11 | 12 | data AExpr = Ref String 13 | | GetEnv String Integer 14 | deriving (Eq, Show) 15 | 16 | data BinOp 17 | = Add 18 | | Sub 19 | | Mul 20 | | Div 21 | deriving (Eq, Ord, Show) 22 | 23 | data Expr 24 | = Num Int 25 | | BinOp BinOp AExpr AExpr 26 | | If0 AExpr Expr Expr 27 | | Let 28 | String 29 | Expr 30 | Expr 31 | | App String [AExpr] 32 | | AppClos AExpr [AExpr] 33 | | NewClos String [AExpr] 34 | | Atomic AExpr 35 | deriving (Eq, Show) 36 | 37 | 38 | freshBinding :: (Monad m, MonadFresh m) => String -> LL.Expr -> m (AExpr, Expr -> Expr) 39 | freshBinding _ (LL.Ref name) = pure (Ref name, id) 40 | freshBinding _ (LL.GetEnv envName index) = pure (GetEnv envName index, id) 41 | freshBinding prefix value = do 42 | name <- (prefix ++) . show <$> next prefix 43 | normalValue <- aNormalizeExpr value 44 | return (Ref name, Let name normalValue) 45 | 46 | 47 | bindMany :: (Monad m, MonadFresh m) => String -> [LL.Expr] -> m ([AExpr], Expr -> Expr) 48 | bindMany prefix values = do 49 | binders <- zipWithM indexedBinding [0..] values 50 | return (map fst binders, \body -> foldr snd body binders) 51 | where 52 | indexedBinding :: (Monad m, MonadFresh m) => Int -> LL.Expr -> m (AExpr, Expr -> Expr) 53 | indexedBinding i = freshBinding $ prefix ++ show i ++ "_" 54 | 55 | 56 | aNormalizeBinOp :: (Monad m, MonadFresh m) => String -> LL.Expr -> LL.Expr -> BinOp -> m Expr 57 | aNormalizeBinOp name a b op = do 58 | (aRef, aLet) <- freshBinding ("_" ++ name ++ "_a_") a 59 | (bRef, bLet) <- freshBinding ("_" ++ name ++ "_b_") b 60 | return $ aLet $ bLet $ BinOp op aRef bRef 61 | 62 | 63 | aNormalizeExpr :: (Monad m, MonadFresh m) => LL.Expr -> m Expr 64 | aNormalizeExpr (LL.Num n) = 65 | pure $ Num n 66 | 67 | aNormalizeExpr (LL.Plus a b) = aNormalizeBinOp "add" a b Add 68 | aNormalizeExpr (LL.Minus a b) = aNormalizeBinOp "sub" a b Sub 69 | aNormalizeExpr (LL.Mult a b) = aNormalizeBinOp "mul" a b Mul 70 | aNormalizeExpr (LL.Divide a b) = aNormalizeBinOp "div" a b Div 71 | 72 | aNormalizeExpr (LL.If0 c t f) = do 73 | (cRef, cLet) <- freshBinding "_if_c_" c 74 | tValue <- aNormalizeExpr t 75 | fValue <- aNormalizeExpr f 76 | return $ cLet $ If0 cRef tValue fValue 77 | 78 | aNormalizeExpr (LL.Let name value body) = Let name <$> aNormalizeExpr value <*> aNormalizeExpr body 79 | 80 | aNormalizeExpr (LL.Ref name) = pure $ Atomic $ Ref name 81 | 82 | aNormalizeExpr (LL.App name args) = do 83 | (refs, binding) <- bindMany "_arg" args 84 | return $ binding $ App name refs 85 | 86 | aNormalizeExpr (LL.AppClos closure args) = do 87 | (cRef, cLet) <- freshBinding "_clos_" closure 88 | (refs, binding) <- bindMany "_arg" args 89 | return $ cLet $ binding $ AppClos cRef refs 90 | 91 | aNormalizeExpr (LL.NewClos functionName envVars) = do 92 | (refs, binding) <- bindMany "_envVar" envVars 93 | return $ binding $ NewClos functionName refs 94 | 95 | aNormalizeExpr (LL.GetEnv envName index) = pure $ Atomic $ GetEnv envName index 96 | 97 | 98 | aNormalizeDef :: (Monad m, MonadFresh m) => LL.Def -> m Def 99 | aNormalizeDef (LL.ClosureDef name envName argNames body) = ClosureDef name envName argNames <$> aNormalizeExpr body 100 | 101 | 102 | aNormalizeProg :: (Monad m, MonadFresh m) => LL.Prog -> m Prog 103 | aNormalizeProg (LL.Prog defs main) = do 104 | defs' <- mapM aNormalizeDef defs 105 | main' <- aNormalizeExpr main 106 | return $ Prog defs' main' -------------------------------------------------------------------------------- /src/CmdLine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns, OverloadedStrings #-} 2 | 3 | module CmdLine where 4 | 5 | import Control.Monad ( (>=>) ) 6 | import Control.Monad.Except (ExceptT, Except, liftEither, mapExceptT, runExcept) 7 | import Control.Monad.Identity (Identity(..)) 8 | import Data.ByteString (ByteString) 9 | import qualified Data.ByteString as BS 10 | import qualified Data.ByteString.Char8 as BSC 11 | import qualified Data.ByteString.UTF8 as BSU 12 | import Data.Maybe (fromMaybe) 13 | import Data.Map (Map) 14 | import qualified Data.Map as Map 15 | import qualified Data.Set as Set 16 | import System.Directory (removeFile) 17 | import System.Exit 18 | import System.FilePath (replaceExtension) 19 | import System.IO 20 | import System.Process 21 | 22 | import ANorm (aNormalizeProg) 23 | import CmdLineArgs 24 | import CodegenMonad (genModule, serialize) 25 | import Fresh (Fresh, evalFresh) 26 | import Infer (infer) 27 | import LowLevel (runConvert) 28 | import Parsing (parse) 29 | import Pretty 30 | 31 | 32 | evalInnerFresh :: ExceptT e Fresh b -> Map String Integer -> Except e b 33 | evalInnerFresh comp state = mapExceptT (Identity . flip evalFresh state) comp 34 | 35 | 36 | doEitherIO :: Either e a -> (a -> IO b) -> IO (Either e b) 37 | doEitherIO a fn = either (return . Left) (fmap Right . fn) a 38 | 39 | 40 | readBProcess :: String -> [String] -> ByteString -> IO ByteString 41 | readBProcess cmd args input = do 42 | let process = (proc cmd args){std_in=CreatePipe, std_out=CreatePipe} 43 | (Just hInput, Just hOutput, _, processHandle) <- createProcess process 44 | hSetBinaryMode hInput True 45 | hSetBinaryMode hOutput True 46 | hPutStr hInput $ BSC.unpack input 47 | exitCode <- waitForProcess processHandle 48 | result <- BSC.pack <$> hGetContents hOutput 49 | case exitCode of 50 | ExitSuccess -> return result 51 | ExitFailure code -> error $ cmd ++ concatMap ((' ':) . show) args ++ " (exit " ++ show code ++ ")" 52 | 53 | 54 | writeOutput :: Args -> IO () 55 | writeOutput args@Args{outputFile, outputFormat, inputFile} = do 56 | result <- produceOutput args 57 | either printError writeOutput result 58 | where 59 | printError :: String -> IO () 60 | printError err = putStrLn $ "Error: " ++ err 61 | 62 | writeOutput :: ByteString -> IO () 63 | writeOutput = case outputPath of 64 | Just path -> BS.writeFile path 65 | Nothing -> putStr . BSU.toString 66 | 67 | outputPath :: Maybe String 68 | outputPath = case (outputFile, outputFormat) of 69 | (Just _, EXE) -> Nothing 70 | (Just _, _) -> outputFile 71 | (Nothing, OBJ) -> Just $ replaceExtension (fromMaybe "gen" inputFile) ".o" 72 | (Nothing, _) -> Nothing 73 | 74 | 75 | produceOutput :: Args -> IO (Either String ByteString) 76 | produceOutput args@Args{outputFile, outputFormat, optimizationFlag} = do 77 | (filename, input) <- getInput args 78 | let parsed = parse filename $ BSU.toString input 79 | inferred = parsed >>= infer 80 | compiled = do { prog <- parsed; _ <- infer prog; return $ runConvert prog Set.empty } 81 | freshNormalized = liftEither compiled >>= aNormalizeProg 82 | normalized = runExcept $ evalInnerFresh freshNormalized Map.empty 83 | llvmModule = runExcept $ evalInnerFresh (freshNormalized >>= genModule) Map.empty 84 | mayabeOptLL = if null optimizationFlag then return else optimize args 85 | llvm = doEitherIO llvmModule $ (fmap BSU.fromString . serialize) >=> optimize args 86 | obj = llvm >>= flip doEitherIO (assemble "obj" args) 87 | defaultExeFile = replaceExtension filename ".out" 88 | case outputFormat of 89 | Parsed -> return $ BSU.fromString . pretty <$> parsed 90 | Typed -> return $ BSU.fromString . pretty <$> inferred 91 | Compiled -> return $ BSU.fromString . pretty <$> compiled 92 | Normalized -> return $ BSU.fromString . pretty <$> normalized 93 | LLVM -> doEitherIO llvmModule $ (fmap BSU.fromString . serialize) >=> mayabeOptLL 94 | ASM -> llvm >>= flip doEitherIO (assemble "asm" args) 95 | OBJ -> obj 96 | EXE -> obj >>= flip doEitherIO (fmap (const "") . link args (fromMaybe defaultExeFile outputFile)) 97 | Run -> obj >>= flip doEitherIO (link args defaultExeFile >=> execute) 98 | 99 | 100 | getInput :: Args -> IO (String, ByteString) 101 | getInput Args{inputFile} = do 102 | input <- maybe BS.getContents BS.readFile inputFile 103 | return (fromMaybe "stdin" inputFile, input) 104 | 105 | 106 | optimize :: Args -> ByteString -> IO ByteString 107 | optimize Args{optimizationFlag} = readBProcess "opt" args 108 | where 109 | baseArgs = ["-S"] 110 | args = maybe baseArgs (:baseArgs) optimizationFlag 111 | 112 | 113 | assemble :: String -> Args -> ByteString -> IO ByteString 114 | assemble filetype Args{optimizationFlag} = readBProcess "llc" args 115 | where 116 | baseArgs = ["--relocation-model=pic", "-filetype", filetype] 117 | args = case optimizationFlag of 118 | Just f | f `elem` ["-O0", "-O1", "-O2", "-O3"] -> f : baseArgs 119 | _ -> baseArgs 120 | 121 | 122 | -- | Compile the runtime C component. Returns the name of the output object file 123 | compileRuntimeC :: Args -> IO String 124 | compileRuntimeC Args{debugRuntime} = readProcess "clang" args "" >> return output 125 | where 126 | input = "runtime.c" 127 | output = "runtime.o" 128 | baseArgs = ["-c", "-fPIC", "-O3", "-flto", "-o", output, input] 129 | debugFlag = "-DDEBUG" 130 | args = if debugRuntime then debugFlag : baseArgs else baseArgs 131 | 132 | 133 | link :: Args -> String -> ByteString -> IO String 134 | link args@Args{inputFile, optimizationFlag} output input = do 135 | runtimeFileName <- compileRuntimeC args 136 | let objFileName = replaceExtension (fromMaybe "gen" inputFile) ".o" 137 | BS.writeFile objFileName input 138 | let baseArgs = ["-flto", "-o", output, runtimeFileName, objFileName] 139 | args = maybe baseArgs (:baseArgs) optimizationFlag 140 | _ <- readProcess "clang" args "" 141 | removeFile objFileName 142 | return output 143 | 144 | 145 | execute :: String -> IO ByteString 146 | execute filename = readBProcess ("./" ++ filename) [] "" <* removeFile filename 147 | -------------------------------------------------------------------------------- /src/CmdLineArgs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module CmdLineArgs where 4 | 5 | import Options.Applicative 6 | 7 | 8 | data OutputFormat 9 | = Parsed -- ^ Expr 10 | | Typed -- ^ Types 11 | | Compiled -- ^ LowLevel 12 | | Normalized -- ^ ANorm 13 | | LLVM -- ^ LLVM IR 14 | | ASM -- ^ Assembly file 15 | | OBJ -- ^ Object file 16 | | EXE -- ^ Linked executable file 17 | | Run -- ^ Output of executable 18 | deriving (Eq, Show) 19 | 20 | 21 | data Args = Args 22 | { debugRuntime :: Bool 23 | , outputFile :: Maybe String 24 | , outputFormat :: OutputFormat 25 | , optimizationFlag :: Maybe String 26 | , inputFile :: Maybe String 27 | } deriving(Eq, Show) 28 | 29 | 30 | defaultArgs :: Args 31 | defaultArgs = Args 32 | { debugRuntime = False 33 | , outputFile = Nothing 34 | , outputFormat = Run 35 | , optimizationFlag = Nothing 36 | , inputFile = Nothing 37 | } 38 | 39 | 40 | argParser :: Parser Args 41 | argParser = Args 42 | <$> switch 43 | ( long "debug-runtime" 44 | <> help "Print debug output from the runtime" 45 | ) 46 | <*> optional (strOption 47 | ( long "output" 48 | <> short 'o' 49 | <> metavar "FILE" 50 | <> help "Output filename" 51 | )) 52 | <*> option outputFormatReader 53 | ( long "format" 54 | <> short 'f' 55 | <> metavar "FORMAT" 56 | <> value (outputFormat defaultArgs) 57 | <> help "The output format. One of [parsed,typed,compiled,normalized,llvm,\ 58 | \asm,obj,exe,run]. Default is run." 59 | ) 60 | <*> optional optFlagParser 61 | <*> optional (argument str 62 | ( metavar "FILE" 63 | <> help "File to compile. If not specified code is read from stdin" 64 | )) 65 | 66 | 67 | outputFormatReader :: ReadM OutputFormat 68 | outputFormatReader = maybeReader $ \case 69 | "parsed" -> Just Parsed 70 | "typed" -> Just Typed 71 | "compiled" -> Just Compiled 72 | "normalized" -> Just Normalized 73 | "llvm" -> Just LLVM 74 | "asm" -> Just ASM 75 | "obj" -> Just OBJ 76 | "exe" -> Just EXE 77 | "run" -> Just Run 78 | _ -> Nothing 79 | 80 | 81 | optFlagParser :: Parser String 82 | optFlagParser = option levelReader 83 | ( long "optimization" 84 | <> short 'O' 85 | <> metavar "LEVEL" 86 | <> help "Level of optimization to use. Passed to clang and opt. One of [0,1,2,3,s,z]" 87 | ) 88 | where 89 | levelReader = maybeReader $ \case 90 | "0" -> Just "-O0" 91 | "1" -> Just "-O1" 92 | "2" -> Just "-O2" 93 | "3" -> Just "-O3" 94 | "s" -> Just "-Os" 95 | "z" -> Just "-Oz" 96 | _ -> Nothing -------------------------------------------------------------------------------- /src/CodegenMonad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns, OverloadedStrings #-} 2 | 3 | module CodegenMonad where 4 | 5 | import Control.Monad.Except hiding (void) 6 | import Control.Monad.Reader hiding (void) 7 | import Control.Monad.State.Strict hiding (void) 8 | import Data.ByteString (ByteString) 9 | import qualified Data.ByteString.Char8 as CBS (pack, unpack) 10 | import qualified Data.ByteString.Short as SBS (toShort) 11 | import Data.Map (Map) 12 | import qualified Data.Map as Map 13 | 14 | import LLVM.AST ( Module, Operand(ConstantOperand), mkName ) 15 | import qualified LLVM.AST.IntegerPredicate as Pred ( IntegerPredicate(EQ) ) 16 | import LLVM.AST.Type 17 | import qualified LLVM.AST.Constant as C 18 | import LLVM.Context ( withContext ) 19 | import LLVM.Module ( moduleLLVMAssembly, withModuleFromAST ) 20 | 21 | import LLVM.IRBuilder.Constant 22 | import LLVM.IRBuilder.Instruction 23 | import LLVM.IRBuilder.Module 24 | import LLVM.IRBuilder.Monad 25 | 26 | import ANorm 27 | import Fresh 28 | import Pretty 29 | import RuntimeDefs 30 | 31 | 32 | generate :: Prog -> Fresh (IO ByteString) 33 | generate prog = do 34 | llvmModule <- either error id <$> runExceptT (genModule prog) 35 | return $ withContext $ \ctx -> withModuleFromAST ctx llvmModule moduleLLVMAssembly 36 | 37 | 38 | serialize :: Module -> IO String 39 | serialize mod = withContext $ \ctx -> withModuleFromAST ctx mod (fmap CBS.unpack . moduleLLVMAssembly) 40 | 41 | 42 | genModule :: Prog -> ExceptT String Fresh Module 43 | genModule prog = buildModuleT "tl-module" $ do 44 | runtime <- defineRuntime 45 | flip runReaderT runtime $ flip evalStateT Map.empty $ genProgram prog 46 | 47 | 48 | type Env = Map String Operand 49 | 50 | type ModuleState = StateT Env (ReaderT Runtime (ModuleBuilderT (ExceptT String Fresh))) 51 | 52 | type Codegen = IRBuilderT ModuleState 53 | 54 | 55 | genProgram :: Prog -> ModuleState () 56 | genProgram (Prog progDefs expr) = do 57 | -- add all defs to the env 58 | mapM_ addDefToEnv progDefs 59 | -- define all functions 60 | mapM_ genDef progDefs 61 | -- define main 62 | function "main" [] i32 mainBody 63 | return () 64 | where 65 | mainBody :: [Operand] -> Codegen () 66 | mainBody [] = do 67 | runtime@Runtime{printf, printObject, printScope} <- ask 68 | resultObj <- genExpr expr 69 | result <- getInt runtime resultObj 70 | formatString <- globalStringPtr "%d\n" "main_fmt_string" 71 | call (FunctionType i32 [ptr] True) printf [(ConstantOperand formatString, []), (result, [])] 72 | -- force the compiler to keep debugging functions even when --debug-runtime is off 73 | -- uncomment for debugging binaries 74 | -- _ <- call (FunctionType void [ptr] False) printObject [(resultObj, [])] 75 | -- _ <- call (FunctionType void [] False) printScope [] 76 | ret (int32 0) 77 | 78 | addDefToEnv :: Def -> ModuleState () 79 | addDefToEnv (ClosureDef name _ argNames _) = do 80 | Runtime{header} <- ask 81 | let operand = ConstantOperand $ C.GlobalReference (mkName name) 82 | numArgs = 1 + length argNames 83 | -- ty = ptr $ FunctionType (ptr header) (replicate numArgs $ ptr header) False 84 | modify $ Map.insert name operand 85 | 86 | 87 | genDef :: Def -> ModuleState () 88 | genDef (ClosureDef name envName argNames body) = do 89 | Runtime{header} <- ask 90 | let params = [(ptr, paramName name) | name <- envName : argNames] 91 | function (mkName name) params ptr defineBody 92 | return () 93 | where 94 | paramName :: String -> ParameterName 95 | paramName = ParameterName . SBS.toShort . CBS.pack 96 | 97 | defineBody :: [Operand] -> Codegen () 98 | defineBody args = do 99 | runtime <- ask 100 | oldEnv <- get 101 | mapM_ modify $ zipWith Map.insert (envName:argNames) args 102 | mapM_ (pushScope runtime) args 103 | let cleanup = mapM_ (const $ popScope runtime) args 104 | genExprTailPosition body cleanup <* put oldEnv 105 | 106 | 107 | genExprTailPosition :: Expr -> Codegen () -> Codegen () 108 | genExprTailPosition expr cleanup = contextualize expr $ case expr of 109 | If0 cond tBranch fBranch -> do 110 | runtime <- ask 111 | condValue <- genAExpr cond >>= getInt runtime 112 | comp <- icmp Pred.EQ condValue (int64 0) 113 | trueLabel <- uniqueName "trueBlock" 114 | falseLabel <- uniqueName "falseBlock" 115 | condBr comp trueLabel falseLabel 116 | -- true block 117 | emitBlockStart trueLabel 118 | genExprTailPosition tBranch cleanup 119 | -- false block 120 | emitBlockStart falseLabel 121 | genExprTailPosition fBranch cleanup 122 | 123 | Let name binding body -> do 124 | runtime <- ask 125 | oldEnv <- get 126 | bindingValue <- genExpr binding 127 | modify $ Map.insert name bindingValue 128 | pushScope runtime bindingValue 129 | genExprTailPosition body (popScope runtime >> cleanup) <* put oldEnv 130 | 131 | App name args -> undefined 132 | 133 | AppClos fn args -> do 134 | runtime <- ask 135 | fnValue <- genAExpr fn 136 | argValues <- mapM genAExpr args 137 | cleanup 138 | result <- callClosure runtime fnValue argValues 139 | ret result 140 | 141 | other -> do 142 | result <- genExpr other 143 | cleanup 144 | ret result 145 | 146 | 147 | genExpr :: Expr -> Codegen Operand 148 | genExpr expr = contextualize expr $ case expr of 149 | Num n -> do 150 | runtime <- ask 151 | createInt runtime (int64 (fromIntegral n)) 152 | 153 | BinOp op a b -> do 154 | runtime <- ask 155 | aVal <- genAExpr a >>= getInt runtime 156 | bVal <- genAExpr b >>= getInt runtime 157 | resultValue <- case op of 158 | Add -> add aVal bVal 159 | Sub -> sub aVal bVal 160 | Mul -> mul aVal bVal 161 | Div -> sdiv aVal bVal 162 | createInt runtime resultValue 163 | 164 | If0 cond tBranch fBranch -> do 165 | runtime <- ask 166 | condValue <- genAExpr cond >>= getInt runtime 167 | comp <- icmp Pred.EQ condValue (int64 0) 168 | trueLabel <- uniqueName "trueBlock" 169 | falseLabel <- uniqueName "falseBlock" 170 | doneLabel <- uniqueName "doneBlock" 171 | condBr comp trueLabel falseLabel 172 | -- true block 173 | emitBlockStart trueLabel 174 | tRes <- genExpr tBranch 175 | br doneLabel 176 | -- false block 177 | emitBlockStart falseLabel 178 | fRes <- genExpr fBranch 179 | br doneLabel 180 | -- done block 181 | emitBlockStart doneLabel 182 | phi [(tRes, trueLabel), (fRes, falseLabel)] 183 | 184 | Let name binding body -> do 185 | runtime <- ask 186 | oldEnv <- get 187 | bindingValue <- genExpr binding 188 | modify $ Map.insert name bindingValue 189 | pushScope runtime bindingValue 190 | result <- genExpr body 191 | popScope runtime 192 | put oldEnv 193 | return result 194 | 195 | App name args -> undefined 196 | 197 | AppClos fn args -> do 198 | runtime <- ask 199 | fnValue <- genAExpr fn 200 | argValues <- mapM genAExpr args 201 | callClosure runtime fnValue argValues 202 | 203 | NewClos fnName bindings -> do 204 | runtime <- ask 205 | maybeFn <- gets $ Map.lookup fnName 206 | fn <- maybe (throwError $ "Undefined function: " ++ fnName) return maybeFn 207 | bindingValues <- mapM genAExpr bindings 208 | createClosure runtime fn bindingValues [] 209 | 210 | Atomic a -> genAExpr a 211 | 212 | 213 | genAExpr :: AExpr -> Codegen Operand 214 | genAExpr expr = contextualize expr $ case expr of 215 | Ref name -> do 216 | value <- gets $ Map.lookup name 217 | maybe (throwError $ "Undefined variable: " ++ name) return value 218 | 219 | GetEnv envName index -> do 220 | env <- genAExpr (Ref envName) 221 | runtime <- ask 222 | getSlot runtime env (int64 index) 223 | -------------------------------------------------------------------------------- /src/Fresh.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} 2 | 3 | module Fresh where 4 | 5 | import Control.Monad.Except 6 | import Control.Monad.Identity 7 | import Control.Monad.Reader 8 | import Control.Monad.State.Strict 9 | import Control.Monad.Trans.State.Strict (liftListen, liftPass) 10 | import Control.Monad.Writer 11 | import Data.ByteString.Char8 (pack) 12 | import Data.ByteString.Short (toShort) 13 | import Data.Map (Map) 14 | import qualified Data.Map as Map 15 | import Data.Maybe (fromMaybe) 16 | 17 | import LLVM.AST 18 | import LLVM.IRBuilder.Module 19 | import LLVM.IRBuilder.Monad 20 | 21 | 22 | class MonadFresh m where 23 | next :: String -> m Integer 24 | 25 | uniqueName :: (Functor m, MonadFresh m) => String -> m Name 26 | uniqueName name = Name . toShort . pack . (name ++) . show <$> next name 27 | 28 | fresh :: (Functor m, MonadFresh m) => m Name 29 | fresh = UnName . fromIntegral <$> next "" 30 | 31 | 32 | newtype FreshT m a = 33 | FreshT { freshState :: StateT (Map String Integer) m a } 34 | deriving (Functor, Applicative, Monad, MonadTrans) 35 | 36 | evalFreshT :: Monad m => FreshT m a -> Map String Integer -> m a 37 | evalFreshT = evalStateT . freshState 38 | 39 | runFreshT :: Monad m => FreshT m a -> Map String Integer -> m (a, Map String Integer) 40 | runFreshT = runStateT . freshState 41 | 42 | 43 | type Fresh = FreshT Identity 44 | 45 | evalFresh :: FreshT Identity a -> Map String Integer -> a 46 | evalFresh = evalState . freshState 47 | 48 | 49 | instance Monad m => MonadFresh (FreshT m) where 50 | next name = FreshT $ do 51 | count <- gets $ fromMaybe 0 . Map.lookup name 52 | modify $ Map.insert name (count + 1) 53 | return count 54 | 55 | instance (MonadFresh m, Monad m) => MonadFresh (ModuleBuilderT m) where 56 | next = lift . next 57 | 58 | instance (MonadFresh m, Monad m) => MonadFresh (IRBuilderT m) where 59 | next = lift . next 60 | 61 | instance (MonadFresh m, Monad m) => MonadFresh (ReaderT r m) where 62 | next = lift . next 63 | 64 | instance (MonadFresh m, Monad m) => MonadFresh (ExceptT e m) where 65 | next = lift . next 66 | 67 | instance (MonadFresh m, Monad m) => MonadFresh (StateT s m) where 68 | next = lift . next 69 | 70 | instance MonadState s m => MonadState s (FreshT m) where 71 | get = lift get 72 | put = lift . put 73 | state = lift . state 74 | 75 | instance MonadWriter w m => MonadWriter w (FreshT m) where 76 | writer = lift . writer 77 | listen = FreshT . liftListen listen . freshState 78 | pass = FreshT . liftPass pass . freshState 79 | 80 | instance MonadReader r m => MonadReader r (FreshT m) where 81 | ask = lift ask 82 | local f = FreshT . (mapStateT . local) f . freshState 83 | 84 | -- TODO: Add these to a test suite 85 | -- a :: FreshT (State Int) String 86 | -- a = return "Hi" 87 | -- 88 | -- b :: FreshT (State Int) Name 89 | -- b = a >>= uniqueName 90 | -- 91 | -- test :: Name 92 | -- test = flip evalState 24 . flip evalFreshT (Map.fromList []) $ b 93 | -- 94 | -- c :: StateT Int Fresh Name 95 | -- c = uniqueName "Var" 96 | -- 97 | -- test2 :: Name 98 | -- test2 = flip evalFresh (Map.fromList []) . flip evalStateT 42 $ c 99 | -------------------------------------------------------------------------------- /src/HighLevel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | 4 | module HighLevel where 5 | 6 | import qualified Data.Set as Set 7 | import qualified Data.Map as Map 8 | 9 | import Scope 10 | 11 | newtype VarIdent = VarIdent String deriving (Eq, Ord, Show) 12 | newtype TypeIdent = TypeIdent String deriving (Eq, Ord, Show) 13 | newtype ConsIdent = ConsIdent String deriving (Eq, Ord, Show) 14 | 15 | data Prog = Prog [Def] [Expr] deriving (Eq, Ord, Show) 16 | 17 | data Def = StructDef TypeRef [(ConsIdent, [TypeRef])] deriving (Eq, Ord, Show) 18 | data TypeRef = TypeRef TypeIdent [TypeIdent] deriving (Eq, Ord, Show) 19 | 20 | data Expr = Nat Int 21 | | BinOp BinOp Expr Expr 22 | | If0 Expr Expr Expr 23 | | Ref VarIdent 24 | | Let VarIdent Expr Expr 25 | | Letrec VarIdent Expr Expr 26 | | Lambda [VarIdent] Expr 27 | | App Expr [Expr] 28 | | Match Expr [(MatchPattern, Expr)] 29 | deriving (Eq, Ord, Show) 30 | 31 | data MatchPattern = ConsPattern ConsIdent [MatchPattern] 32 | | VarBinding VarIdent 33 | deriving (Eq, Ord, Show) 34 | 35 | 36 | data BinOp 37 | = Add 38 | | Sub 39 | | Mul 40 | | Div 41 | -- | Mod 42 | deriving (Eq, Ord, Show) 43 | 44 | 45 | instance Scope Expr VarIdent where 46 | freeVars (Nat _) = Set.empty 47 | freeVars (BinOp _ a b) = freeVars a `Set.union` freeVars b 48 | freeVars (If0 c t f) = Set.unions [freeVars c, freeVars t, freeVars f] 49 | freeVars (Ref name) = Set.singleton name 50 | freeVars (Let name binding body) = freeVars binding `Set.union` Set.delete name (freeVars body) 51 | freeVars (Letrec name binding body) = Set.delete name $ freeVars binding `Set.union` freeVars body 52 | freeVars (Lambda args body) = freeVars body `Set.difference` Set.fromList args 53 | freeVars (App fn args) = Set.unions $ map freeVars (fn:args) 54 | 55 | instance Substitute Expr where 56 | substitute trySub expr = case trySub expr of 57 | Just ex -> ex 58 | Nothing -> case expr of 59 | Nat _ -> expr 60 | BinOp op a b -> BinOp op (recur a) (recur b) 61 | If0 c t f -> If0 (recur c) (recur t) (recur f) 62 | Ref _ -> expr 63 | Let name binding body -> Let name (recur binding) (recur body) 64 | Letrec name binding body -> Letrec name (recur binding) (recur body) 65 | Lambda args body -> Lambda args (recur body) 66 | App fn args -> App (recur fn) (map recur args) 67 | where 68 | recur = substitute trySub 69 | 70 | 71 | replaceRefs :: Map.Map VarIdent Expr -> Expr -> Expr 72 | replaceRefs initialSubs = substitute $ go initialSubs 73 | where 74 | go :: Map.Map VarIdent Expr -> Expr -> Maybe Expr 75 | go subs (Ref name) = substitute (go $ Map.delete name subs) <$> Map.lookup name subs 76 | go subs (Let name value body) = Just $ Let name (substitute (go subs) value) (substitute (go $ Map.delete name subs) body) 77 | go subs (Letrec name value body) = let subs' = Map.delete name subs in Just $ Letrec name (substitute (go subs') value) (substitute (go subs') body) 78 | go subs (Lambda args body) = Just $ Lambda args $ substitute (go $ foldr Map.delete subs args) body 79 | go _ _ = Nothing 80 | -------------------------------------------------------------------------------- /src/Infer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Infer where 3 | 4 | import Control.Monad.Except 5 | import Control.Monad.Reader 6 | import Control.Monad.State 7 | import Data.Map (Map, (!)) 8 | import qualified Data.Map as Map 9 | import qualified Data.Set as Set 10 | 11 | -- import Debug.Trace (trace) 12 | 13 | import HighLevel 14 | import Pretty 15 | import Scope 16 | import Types 17 | import LLVM.AST (Type(resultType)) 18 | 19 | type TypeEnv = Map VarIdent PolyType 20 | type ConsEnv = Map ConsIdent PolyType 21 | 22 | type Subs = Map TVarIdent MonoType 23 | 24 | data InferState = InferState TVarIdent (Map TVarIdent MonoType) 25 | type Infer = ReaderT ConsEnv (State InferState) 26 | 27 | type Fresh = State TVarIdent 28 | 29 | -- | Create a fresh type variable 30 | fresh :: Infer MonoType 31 | fresh = do 32 | (InferState (TVarIdent n) s) <- get 33 | put $ InferState (TVarIdent (n + 1)) s 34 | return $ TVar $ TVarIdent n 35 | 36 | 37 | -- | A version of zipWithM that throws an error if the lengths of the inputs don't match 38 | zipWithMSafe :: MonadError String m => (a -> b -> m c) -> [a] -> [b] -> m [c] 39 | zipWithMSafe fn [] [] = pure [] 40 | zipWithMSafe fn (a:as) (b:bs) = do 41 | c <- fn a b 42 | rest <- zipWithMSafe fn as bs 43 | return $ c : rest 44 | zipWithMSafe _ _ _ = throwError "Type Error: Arity mismatch" 45 | 46 | 47 | -- | lookup and instantiate the type of a constructor 48 | lookupConstructorType :: ConsIdent -> ExceptT String Infer ([MonoType], MonoType) 49 | lookupConstructorType name = do 50 | env <- ask 51 | monoType <- case Map.lookup name env of 52 | Nothing -> throwError $ "Undefined constructor: " ++ show name 53 | (Just polyType) -> lift $ instantiate polyType 54 | case monoType of 55 | (TLam args ret) -> return (args, ret) 56 | t@(TApp _ _) -> return ([], t) 57 | bad -> throwError $ "Constructor is not a function: " ++ show name ++ ": " ++ show bad 58 | 59 | 60 | -- | Core types 61 | numType :: MonoType 62 | numType = TApp "Num" [] 63 | 64 | 65 | -- | Type of a BinOp as if it were a bound variable 66 | binOpType :: BinOp -> PolyType 67 | binOpType _ = numericBinOpType 68 | where 69 | numericBinOpType = PolyType [] (TLam [numType, numType] numType) 70 | 71 | 72 | -- | Instantiate a polytype by creating fresh monotypes for all its arguments and subbing them in 73 | instantiate :: PolyType -> Infer MonoType 74 | instantiate (PolyType idents term) = do 75 | freshTVars <- mapM (const fresh) idents 76 | let subs = Map.fromList $ zip idents freshTVars 77 | return $ subMonoType subs term 78 | where 79 | subMonoType :: Subs -> MonoType -> MonoType 80 | subMonoType subs (TVar n) = 81 | case Map.lookup n subs of 82 | Nothing -> TVar n 83 | (Just t) -> subMonoType (Map.delete n subs) t -- delete from the sub so we can't hang 84 | subMonoType subs (TLam args ret) = TLam (map (subMonoType subs) args) (subMonoType subs ret) 85 | subMonoType subs (TApp name args) = TApp name $ map (subMonoType subs) args 86 | 87 | 88 | -- | Make a polytype that quantifies all free type variables in a monotype that are not in the environment 89 | generalize :: TypeEnv -> MonoType -> Infer PolyType 90 | generalize env monoType = do 91 | resolved <- resolve monoType 92 | let tvars = Set.toList $ freeVars resolved `Set.difference` freeInEnv 93 | return $ PolyType tvars resolved 94 | where 95 | freeInEnv = Set.unions $ map freeVars (Map.elems env) 96 | 97 | 98 | -- | Resolves all bound instances of type variables in a type 99 | resolve :: MonoType -> Infer MonoType 100 | resolve t = do 101 | (InferState _ subs) <- get 102 | return $ go subs t 103 | where 104 | go :: Subs -> MonoType -> MonoType 105 | go subs monoType = case monoType of 106 | TVar ident -> case Map.lookup ident subs of 107 | Nothing -> monoType 108 | (Just other) -> go (Map.delete ident subs) other -- Don't loop forever 109 | TLam args res -> TLam (map (go subs) args) (go subs res) 110 | TApp name args -> TApp name (map (go subs) args) 111 | 112 | 113 | -- | Unify two types, possibly binding a type variable to another type 114 | unify :: MonoType -> MonoType -> ExceptT String Infer () 115 | unify a b = do 116 | a' <- lift $ resolve a 117 | b' <- lift $ resolve b 118 | go a' b' 119 | where 120 | assign :: TVarIdent -> MonoType -> ExceptT String Infer () 121 | assign ident monoType 122 | | monoType == TVar ident = return () 123 | | occurs = throwError $ "Cannot create infinite type: " ++ pretty (TVar ident) ++ " = " ++ pretty monoType 124 | | otherwise = insert 125 | where 126 | occurs = Set.member ident $ freeVars monoType 127 | insert = do 128 | (InferState next subs) <- get 129 | let subs' = Map.insert ident monoType subs 130 | put $ InferState next subs' 131 | 132 | go :: MonoType -> MonoType -> ExceptT String Infer () 133 | go (TVar ident) monoType = assign ident monoType 134 | go monoType (TVar ident) = assign ident monoType 135 | go (TLam argsA retA) (TLam argsB retB) = unifyAll (retA:argsA) (retB:argsB) 136 | go (TApp nameA argsA) (TApp nameB argsB) | nameA == nameB = unifyAll argsA argsB 137 | go badA badB = throwError $ "Type Error: Cannot unify " ++ pretty badA ++ " with " ++ pretty badB 138 | 139 | -- | Unify two lists of types. If the lists are not the same size throw a type error 140 | unifyAll :: [MonoType] -> [MonoType] -> ExceptT String Infer () 141 | unifyAll [] [] = return () 142 | unifyAll (a:as) (b:bs) = unify a b >> unifyAll as bs 143 | unifyAll _ _ = throwError "Type Error: Arity mismatch" 144 | 145 | 146 | -- | Infer the type of an expression 147 | infer :: Prog -> Either String PolyType 148 | infer (Prog defs [expr]) = runInference $ do 149 | constructors <- Map.fromList . concat <$> mapM constructorTypes defs 150 | local (const constructors) $ do 151 | exprType <- inferRec Map.empty expr 152 | lift $ generalize Map.empty exprType 153 | where 154 | runInference :: ExceptT String Infer a -> Either String a 155 | runInference comp = evalState (flip runReaderT Map.empty . runExceptT $ comp) $ InferState (TVarIdent 0) Map.empty 156 | 157 | structMap :: ExceptT String Infer ConsEnv 158 | structMap = Map.fromList . concat <$> mapM constructorTypes defs 159 | 160 | 161 | -- | Create a list of constructor types for a struct definition 162 | constructorTypes :: Def -> ExceptT String Infer [(ConsIdent, PolyType)] 163 | constructorTypes def@(StructDef (TypeRef (TypeIdent name) tvars) constructors) = do 164 | tvarIdents <- mapM (const (lift fresh)) tvars 165 | let tvarsByName = Map.fromList $ zip tvars tvarIdents 166 | structType = TApp name tvarIdents 167 | contextualize def $ mapM (constructorType tvarsByName structType) constructors 168 | where 169 | lookupTVar :: TypeIdent -> Map TypeIdent MonoType -> ExceptT String Infer MonoType 170 | lookupTVar name varMap = case Map.lookup name varMap of 171 | Nothing -> throwError $ "Undefined type variable: " ++ show name 172 | (Just t) -> return t 173 | 174 | mkTApp :: Map TypeIdent MonoType -> TypeRef -> ExceptT String Infer MonoType 175 | mkTApp varMap (TypeRef ident []) | Map.member ident varMap = return $ varMap ! ident 176 | mkTApp varMap (TypeRef (TypeIdent name) tvars) = TApp name <$> mapM (flip lookupTVar varMap) tvars 177 | 178 | constructorType :: Map TypeIdent MonoType -> MonoType -> (ConsIdent, [TypeRef]) -> ExceptT String Infer (ConsIdent, PolyType) 179 | constructorType _ structType (name, []) = do 180 | generalStructType <- lift $ generalize Map.empty structType 181 | return (name, generalStructType) 182 | constructorType varMap structType (name, args) = do 183 | argTypes <- mapM (mkTApp varMap) args 184 | polyType <- lift . generalize Map.empty $ TLam argTypes structType 185 | return (name, polyType) 186 | 187 | 188 | -- | Recursively infer the type of an expression with all the state needed to make that happen 189 | inferRec :: TypeEnv -> Expr -> ExceptT String Infer MonoType 190 | inferRec env expr = do 191 | (InferState _ s1) <- get 192 | -- trace ("\n>>> " ++ pretty expr ++ prettyState s1) $ return () 193 | ret <- contextualize expr $ case expr of 194 | -- lookup s in the env and specialize if it so we can unify its quantified variables with real types 195 | Ref ident -> do 196 | -- allow constructors to be treated as regular variables 197 | constructors <- asks $ Map.mapKeys (\(ConsIdent name) -> VarIdent name) 198 | case Map.lookup ident (Map.union constructors env) of 199 | Nothing -> throwError $ "Undefined Variable: " ++ show ident 200 | (Just polyType) -> lift $ instantiate polyType 201 | 202 | Nat _ -> return numType 203 | 204 | -- typecheck the body with the argNames bound to new type vars in the environment 205 | Lambda argNames body -> do 206 | argTypes <- lift $ mapM (const fresh) argNames 207 | let bindings = Map.fromList $ zip argNames (map (PolyType []) argTypes) 208 | let env' = Map.union bindings env 209 | retType <- inferRec env' body 210 | return $ TLam argTypes retType 211 | 212 | -- infer the value type, generalize it, and then infer the body with the new type in the environment 213 | Let name value body -> do 214 | valueType <- inferRec env value 215 | polyType <- lift $ generalize env valueType 216 | let env' = Map.insert name polyType env 217 | inferRec env' body 218 | 219 | Letrec name value body -> do 220 | freshValueType <- lift fresh 221 | let valueEnv = Map.insert name (PolyType [] freshValueType) env 222 | valueType <- inferRec valueEnv value 223 | unify valueType freshValueType 224 | polyType <- lift $ generalize env valueType 225 | let bodyEnv = Map.insert name polyType env 226 | inferRec bodyEnv body 227 | 228 | Match obj patterns -> do 229 | objType <- inferRec env obj 230 | allBindings <- mapM (inferPattern objType . fst) patterns 231 | let extendEnv :: Map VarIdent MonoType -> Infer TypeEnv 232 | extendEnv bindings = Map.union env <$> mapM (generalize env) bindings 233 | bodyEnvs <- mapM (lift . extendEnv) allBindings 234 | bodyTypes <- zipWithMSafe inferRec bodyEnvs (map snd patterns) 235 | resultType <- lift fresh 236 | forM_ bodyTypes (unify resultType) 237 | return resultType 238 | 239 | App f args -> do 240 | fType <- inferRec env f 241 | -- the extra PolyType will unwrapped in inferCall with no side effects 242 | -- any type variables that need to be instantiated will already be in 243 | -- scope after the type is inferred 244 | inferCall env args $ PolyType [] fType 245 | 246 | If0 cond true false -> do 247 | -- infer call just instantiates the given polytype, so we don't need to worry 248 | -- about freshness because no other type in the environment can get involved 249 | let ident = TVarIdent 0 250 | t = TVar ident 251 | if0Type = PolyType [ident] (TLam [numType, t, t] t) 252 | inferCall env [cond, true, false] if0Type 253 | 254 | BinOp op a b -> inferCall env [a, b] (binOpType op) 255 | 256 | (InferState _ s2) <- get 257 | -- trace ("\n<<< " ++ pretty expr ++ " : " ++ pretty ret ++ prettyState s2) $ return () 258 | return ret 259 | -- where 260 | -- prettyState s = "\n env - " ++ prettyEnv ++ "\n var - " ++ prettySub s 261 | -- prettyEnv = intercalate "\n " $ map prettyEnvEntry $ Map.toList env 262 | -- prettyEnvEntry (VarIdent name, t) = name ++ ": " ++ pretty t 263 | -- prettySub = intercalate "\n " . map prettySubEntry . Map.toList 264 | -- prettySubEntry (tv, t) = pretty (TVar tv) ++ ": " ++ pretty t 265 | 266 | 267 | inferCall :: TypeEnv -> [Expr] -> PolyType -> ExceptT String Infer MonoType 268 | inferCall env args fnPolyType = do 269 | fnType <- lift $ instantiate fnPolyType 270 | argTypes <- mapM (inferRec env) args 271 | resultType <- lift fresh 272 | unify fnType (TLam argTypes resultType) 273 | return resultType 274 | 275 | 276 | -- | Infer the type of a case pattern and return types of all variable bindings 277 | inferPattern :: MonoType -> MatchPattern -> ExceptT String Infer (Map VarIdent MonoType) 278 | inferPattern objType (VarBinding ident) = do 279 | monoType <- lift fresh 280 | unify objType monoType 281 | return $ Map.singleton ident monoType 282 | inferPattern objType (ConsPattern consName subPatterns) = do 283 | (argTypes, structType) <- lookupConstructorType consName 284 | unify objType structType 285 | Map.unions <$> zipWithMSafe inferPattern argTypes subPatterns 286 | -------------------------------------------------------------------------------- /src/LowLevel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} 2 | module LowLevel where 3 | 4 | import qualified Data.Map as Map 5 | import Data.Set (Set) 6 | import qualified Data.Set as Set 7 | import Control.Monad.Writer 8 | import Control.Monad.Reader 9 | 10 | import qualified HighLevel as HL 11 | import Scope 12 | import Fresh 13 | 14 | -- main :: IO () 15 | -- main = do 16 | -- print $ Prog [] example 17 | -- putStrLn "-- becomes --" 18 | -- print . convertProg $ Prog [] example 19 | -- where 20 | -- -- f = lambda x: lambda y: x + y 21 | -- -- plus1 = f(1) 22 | -- -- plus2 = f(2) 23 | -- -- plus1(3) + plus2(3) 24 | -- example = 25 | -- Let "f" (Lambda ["x"] (Lambda ["y"] (Plus (Ref "x") (Ref "y")))) $ 26 | -- Let "plus1" (Call (Ref "f") [Num 1]) $ 27 | -- Let "plus2" (Call (Ref "f") [Num 2]) $ 28 | -- Plus (Call (Ref "plus1") [Num 3]) (Call (Ref "plus2") [Num 3]) 29 | 30 | data Prog = Prog [Def] Expr deriving (Eq, Show) 31 | 32 | -- | A function definition that can be called 33 | data Def 34 | -- | The function definition for a closure. This type of definition has a 35 | -- name, environment name, a list of argument names, and a body 36 | = ClosureDef String String [String] Expr deriving (Eq, Show) 37 | 38 | data Expr = Num Int 39 | | Plus Expr Expr 40 | | Minus Expr Expr 41 | | Mult Expr Expr 42 | | Divide Expr Expr 43 | | If0 Expr Expr Expr 44 | | Let String Expr Expr 45 | | Ref String 46 | | App String [Expr] 47 | | AppClos Expr [Expr] 48 | | NewClos String [Expr] 49 | | GetEnv String Integer 50 | deriving (Eq, Show) 51 | 52 | 53 | instance Scope Expr [Char] where 54 | freeVars expr = case expr of 55 | Num _ -> Set.empty 56 | Plus a b -> freeVars a `Set.union` freeVars b 57 | Minus a b -> freeVars a `Set.union` freeVars b 58 | Mult a b -> freeVars a `Set.union` freeVars b 59 | Divide a b -> freeVars a `Set.union` freeVars b 60 | If0 c t f -> freeVars c `Set.union` freeVars t `Set.union` freeVars f 61 | Let name binding body -> freeVars binding `Set.union` Set.delete name (freeVars body) 62 | Ref name -> Set.singleton name 63 | App name args -> Set.unions $ Set.singleton name : map freeVars args 64 | AppClos fn args -> Set.unions . map freeVars $ fn : args 65 | NewClos fnName bindings -> Set.unions $ Set.singleton fnName : map freeVars bindings 66 | GetEnv _ _ -> Set.empty 67 | 68 | instance Substitute Expr where 69 | substitute trySub expr = case trySub expr of 70 | Just ex -> ex 71 | Nothing -> case expr of 72 | Num _ -> expr 73 | Plus a b -> Plus (recur a) (recur b) 74 | Minus a b -> Minus (recur a) (recur b) 75 | Mult a b -> Mult (recur a) (recur b) 76 | Divide a b -> Divide (recur a) (recur b) 77 | If0 c t f -> If0 (recur c) (recur t) (recur f) 78 | Let name binding body -> Let name (recur binding) (recur body) 79 | Ref _ -> expr 80 | AppClos func args -> AppClos (recur func) (map recur args) 81 | App name args -> App name (map recur args) 82 | NewClos name bindings -> NewClos name (map recur bindings) 83 | GetEnv envName index -> GetEnv envName index 84 | where 85 | recur = substitute trySub 86 | 87 | 88 | runConvert :: HL.Prog -> Set String -> Prog 89 | runConvert (HL.Prog [] [body]) globals = Prog (reverse newDefs) newBody 90 | where 91 | (newBody, newDefs) = runWriter . flip runReaderT globals . flip evalFreshT Map.empty . convert $ body 92 | 93 | 94 | convertNumBinOp :: HL.Expr -> HL.Expr -> HL.BinOp -> FreshT (ReaderT (Set String) (Writer [Def])) Expr 95 | convertNumBinOp a b op = do 96 | a' <- convert a 97 | b' <- convert b 98 | return $ constructor a' b' 99 | where 100 | constructor = case op of 101 | HL.Add -> Plus 102 | HL.Sub -> Minus 103 | HL.Mul -> Mult 104 | HL.Div -> Divide 105 | 106 | 107 | convert :: HL.Expr -> FreshT (ReaderT (Set String) (Writer [Def])) Expr 108 | convert (HL.Nat n) = return $ Num n 109 | 110 | convert (HL.BinOp op a b) = convertNumBinOp a b op 111 | 112 | convert (HL.If0 c t f) = do 113 | c' <- convert c 114 | t' <- convert t 115 | f' <- convert f 116 | return $ If0 c' t' f' 117 | 118 | convert (HL.Let (HL.VarIdent name) binding body) = do 119 | bind <- convert binding 120 | body' <- convert body 121 | return $ Let name bind body' 122 | 123 | convert (HL.Letrec name binding body) = do 124 | let sub expr 125 | | expr == HL.Ref name = Just $ HL.App (HL.Ref name) [HL.Ref name] 126 | | otherwise = Nothing 127 | binding' = HL.Lambda [name] $ substitute sub binding 128 | body' = substitute sub body 129 | convert (HL.Let name binding' body') 130 | 131 | convert (HL.Ref (HL.VarIdent name)) = return $ Ref name 132 | 133 | convert expr@(HL.Lambda args body) = do 134 | let unwrap (HL.VarIdent name) = name 135 | free = map unwrap $ Set.toList $ freeVars expr 136 | indices = Map.fromList $ zip free [0..] 137 | sub (Ref name) = GetEnv "_env" <$> Map.lookup name indices 138 | sub _ = Nothing 139 | name <- freshFunc 140 | body' <- convert body 141 | tell [ClosureDef name "_env" (map unwrap args) (substitute sub body')] 142 | return $ NewClos name $ map Ref free 143 | 144 | convert (HL.App (HL.Ref (HL.VarIdent name)) args) = do 145 | args' <- mapM convert args 146 | isGlobal <- asks $ Set.member name 147 | if isGlobal 148 | then return $ App name args' 149 | else return $ AppClos (Ref name) args' 150 | 151 | convert (HL.App fn args) = do 152 | fn' <- convert fn 153 | args' <- mapM convert args 154 | return $ AppClos fn' args' 155 | 156 | 157 | freshFunc :: FreshT (ReaderT (Set String) (Writer [Def])) String 158 | freshFunc = do 159 | i <- next "_f" 160 | return $ "_f" ++ show i 161 | -------------------------------------------------------------------------------- /src/ParseLisp.hs: -------------------------------------------------------------------------------- 1 | module ParseLisp where 2 | 3 | import Control.Monad (void) 4 | import Data.Char (isSpace, isPrint) 5 | import Data.Void (Void) 6 | import Text.Megaparsec 7 | import Text.Megaparsec.Char 8 | import qualified Text.Megaparsec.Char.Lexer as L 9 | 10 | 11 | type Parser = Parsec Void String 12 | 13 | 14 | data Lisp = Symbol String 15 | | String String 16 | | Number Integer 17 | | Float Double 18 | | List [Lisp] 19 | deriving (Eq, Ord, Show) 20 | 21 | 22 | sc :: Parser () 23 | sc = L.space (void spaceChar) lineComment blockComment 24 | where 25 | lineComment = L.skipLineComment ";" 26 | blockComment = void $ symbol "#;" *> expression 27 | 28 | 29 | lexeme :: Parser a -> Parser a 30 | lexeme = L.lexeme sc 31 | 32 | 33 | symbol :: String -> Parser String 34 | symbol = L.symbol sc 35 | 36 | 37 | symbolLit :: Parser String 38 | symbolLit = label "symbol" . lexeme $ some (satisfy goodChar) 39 | where 40 | goodChar c = not (isSpace c) && notElem c invalid && isPrint c 41 | invalid = "()[]{}\",'`;#|\\" 42 | 43 | 44 | stringLit :: Parser String 45 | stringLit = label "string" . lexeme $ char '"' *> manyTill L.charLiteral (char '"') 46 | 47 | 48 | integerLit :: Parser Integer 49 | integerLit = label "integer" . lexeme $ L.signed (pure ()) L.decimal 50 | 51 | 52 | floatLit :: Parser Double 53 | floatLit = label "float" . lexeme $ L.signed (pure ()) L.float 54 | 55 | 56 | list :: Parser [Lisp] 57 | list = lexeme enclosed 58 | where 59 | enclosed = between (symbol "(") (symbol ")") items 60 | <|> between (symbol "[") (symbol "]") items 61 | <|> between (symbol "{") (symbol "}") items 62 | items = many expression 63 | 64 | 65 | expression :: Parser Lisp 66 | expression = label "expression" $ Float <$> try floatLit 67 | <|> Number <$> try integerLit 68 | <|> Symbol <$> try symbolLit 69 | <|> String <$> try stringLit 70 | <|> List <$> list 71 | 72 | wholeFile :: Parser [Lisp] 73 | wholeFile = sc *> some expression <* eof 74 | -------------------------------------------------------------------------------- /src/Parsing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TupleSections #-} 3 | 4 | module Parsing where 5 | 6 | import Prelude hiding (fail) 7 | 8 | import Control.Monad.Fail 9 | import Data.Bifunctor (first) 10 | import Data.Foldable (foldlM) 11 | import Data.List (isPrefixOf) 12 | import Data.Set (Set) 13 | import qualified Data.Set as Set 14 | import qualified Text.Megaparsec as M (errorBundlePretty, parse) 15 | 16 | import HighLevel 17 | import ParseLisp 18 | import Pretty 19 | 20 | 21 | parse :: String -> String -> Either String Prog 22 | parse filename = first M.errorBundlePretty . M.parse parser filename 23 | where 24 | parser = wholeFile >>= translate 25 | 26 | 27 | translate :: MonadFail m => [Lisp] -> m Prog 28 | translate = foldlM translateSingle $ Prog [] [] 29 | where 30 | translateSingle (Prog defs exprs) s = case s of 31 | List (Symbol name : rest) | Set.member name defKeywords -> do 32 | def <- parseDef name rest 33 | pure $ Prog (def : defs) exprs 34 | other -> Prog defs . (:exprs) <$> parseExpr other 35 | 36 | 37 | parseExpr :: MonadFail f => Lisp -> f Expr 38 | parseExpr expr = case expr of 39 | -- atoms 40 | Symbol _ -> Ref <$> parseIdentifier expr 41 | String s -> fail $ "Unexpected string: " ++ show s 42 | Number n -> return $ Nat $ fromIntegral n 43 | Float f -> fail $ "Unexpected float: " ++ show f 44 | List [] -> fail "Unexpected nil" 45 | -- keywords 46 | List (Symbol name : exprs) | Set.member name keywords -> parseKeyword name exprs 47 | List (Symbol bad : _) | Set.member bad defKeywords -> fail $ "Unexpected definition: " ++ pretty expr 48 | -- assume application if the list does not start with a keyword 49 | List (fn : args) -> App <$> parseExpr fn <*> mapM parseExpr args 50 | 51 | 52 | defKeywords :: Set String 53 | defKeywords = Set.fromList ["struct"] 54 | 55 | 56 | parseDef :: MonadFail m => String -> [Lisp] -> m Def 57 | parseDef keyword exprs = case keyword of 58 | "struct" -> case exprs of 59 | (typeRef : constructors) -> 60 | StructDef <$> parseTypeRef typeRef <*> parseConstructors constructors 61 | _ -> fail $ "Invalid struct: " ++ pretty (List (Symbol "struct" : exprs)) 62 | _ -> fail $ "Unknown keyword: " ++ keyword 63 | where 64 | parseTypeRef ref = case ref of 65 | (Symbol name) -> pure $ TypeRef (TypeIdent name) [] 66 | (List (Symbol name : vars)) -> TypeRef (TypeIdent name) <$> mapM parseTypeVar vars 67 | bad -> fail $ "Invalid type: " ++ pretty bad 68 | where 69 | parseTypeVar (Symbol name) = pure $ TypeIdent name 70 | parseTypeVar bad = fail $ "Invalid type variable: " ++ pretty bad 71 | 72 | parseConstructors = mapM parseOne 73 | where 74 | parseOne (Symbol name) = pure (ConsIdent name, []) 75 | parseOne (List (Symbol name : arguments)) = (ConsIdent name,) <$> mapM parseTypeRef arguments 76 | parseOne bad = fail $ "Invalid constructor: " ++ pretty bad 77 | 78 | 79 | keywords :: Set String 80 | keywords = Set.fromList ["lambda", "let", "letrec", "match", "if0", "+", "-", "*", "/"] 81 | 82 | 83 | parseKeyword :: MonadFail m => String -> [Lisp] -> m Expr 84 | parseKeyword keyword exprs = case keyword of 85 | "lambda" -> case exprs of 86 | [List args, body] -> Lambda <$> mapM parseIdentifier args <*> parseExpr body 87 | _ -> syntaxError 88 | 89 | "let" -> case exprs of 90 | [List [name, value], body] -> Let <$> parseIdentifier name <*> parseExpr value <*> parseExpr body 91 | _ -> syntaxError 92 | 93 | "letrec" -> case exprs of 94 | [List [name, value], body] -> Letrec <$> parseIdentifier name <*> parseExpr value <*> parseExpr body 95 | _ -> syntaxError 96 | 97 | "match" -> case exprs of 98 | (expr : clauses) -> Match <$> parseExpr expr <*> mapM parseMatchClause clauses 99 | 100 | "if0" -> case exprs of 101 | [c, t, f] -> If0 <$> parseExpr c <*> parseExpr t <*> parseExpr f 102 | _ -> syntaxError 103 | 104 | "+" -> parseBinOp Add 105 | "-" -> parseBinOp Sub 106 | "*" -> parseBinOp Mul 107 | "/" -> parseBinOp Div 108 | -- "%" -> parseBinOp Mod 109 | 110 | _ -> fail $ "Unknown keyword: " ++ keyword 111 | where 112 | syntaxError :: MonadFail m => m a 113 | syntaxError = fail $ "Invalid syntax in " ++ keyword ++ " expression" 114 | 115 | parseBinOp :: MonadFail m => BinOp -> m Expr 116 | parseBinOp op = case exprs of 117 | [a, b] -> BinOp op <$> parseExpr a <*> parseExpr b 118 | _ -> syntaxError 119 | 120 | 121 | parseMatchClause :: MonadFail m => Lisp -> m (MatchPattern, Expr) 122 | parseMatchClause (List [pattern, expr]) = do 123 | pat <- parseMatchPattern pattern 124 | body <- parseExpr expr 125 | pure (pat, body) 126 | where 127 | parseMatchPattern (Symbol name) = pure . VarBinding . VarIdent $ name 128 | parseMatchPattern (List (Symbol name : args)) = ConsPattern (ConsIdent name) <$> mapM parseMatchPattern args 129 | parseMatchPattern bad = fail $ "Invalid match pattern: " ++ pretty bad 130 | parseMatchClause bad = fail $ "Invalid match: " ++ pretty bad 131 | 132 | 133 | parseIdentifier :: MonadFail m => Lisp -> m VarIdent 134 | parseIdentifier expr = case expr of 135 | (Symbol name) | invalid name -> fail $ "Invalid identifier: " ++ name 136 | (Symbol name) -> return $ VarIdent name 137 | bad -> fail $ "Invalid identifier: " ++ show bad 138 | where 139 | invalid name = Set.member name keywords || isPrefixOf "__" name 140 | -------------------------------------------------------------------------------- /src/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Pretty where 3 | 4 | import Control.Monad.Except 5 | import Data.List (intercalate) 6 | import Data.Char (ord, chr) 7 | import Data.Map (Map, (!)) 8 | import qualified Data.Map as Map 9 | import Data.Set (Set) 10 | import qualified Data.Set as Set 11 | 12 | import HighLevel 13 | import ParseLisp 14 | import qualified LowLevel as LL 15 | import qualified ANorm as A 16 | import Types 17 | import Scope 18 | 19 | subscript :: Int -> String 20 | subscript = map conv . show 21 | where 22 | conv c = chr $ ord c + 8272 23 | 24 | 25 | class Pretty a where 26 | pretty :: a -> String 27 | 28 | 29 | -- | Add some additional context to an error message 30 | contextualize :: (Pretty c, MonadError String m) => c -> m a -> m a 31 | contextualize context comp = catchError comp (\err -> throwError $ err ++ "\n in " ++ pretty context) 32 | 33 | 34 | instance Pretty Lisp where 35 | pretty expr = case expr of 36 | Symbol s -> s 37 | List exprs -> "(" ++ unwords (map pretty exprs) ++ ")" 38 | String s -> show s 39 | Number n -> show n 40 | Float f -> show f 41 | 42 | 43 | instance Pretty Prog where 44 | pretty (Prog defs exprs) = unlines $ map pretty defs ++ map pretty exprs 45 | 46 | 47 | instance Pretty Def where 48 | pretty (StructDef typeRef constructors) = "(struct " ++ unwords (pretty typeRef : map go constructors) ++ ")" 49 | where go (ConsIdent name, args) = "[" ++ unwords (name : map pretty args) ++ "]" 50 | 51 | 52 | instance Pretty TypeRef where 53 | pretty (TypeRef (TypeIdent name) []) = name 54 | pretty (TypeRef (TypeIdent name) args) = "(" ++ unwords (name : map (\(TypeIdent s) -> s) args) ++ ")" 55 | 56 | 57 | instance Pretty MatchPattern where 58 | pretty (VarBinding (VarIdent name)) = name 59 | pretty (ConsPattern (ConsIdent ident) subPatterns) = "(" ++ unwords (ident : map pretty subPatterns) ++ ")" 60 | 61 | 62 | instance Pretty Expr where 63 | pretty expr = case expr of 64 | Ref name -> unwrap name 65 | Nat n -> show n 66 | Lambda args body -> "(λ (" ++ unwords (map unwrap args) ++ ") " ++ pretty body ++ ")" 67 | Let name value body -> "(let [" ++ unwrap name ++ " " ++ pretty value ++ "] " ++ pretty body ++ ")" 68 | Letrec name value body -> "(letrec [" ++ unwrap name ++ " " ++ pretty value ++ "] " ++ pretty body ++ ")" 69 | Match obj patterns -> "(match " ++ unwords (pretty obj : map prettyMatchClause patterns) ++ ")" 70 | App fn args -> "(" ++ pretty fn ++ " " ++ unwords (map pretty args) ++ ")" 71 | If0 c t f -> "(if0 " ++ pretty c ++ " " ++ pretty t ++ " " ++ pretty f ++ ")" 72 | BinOp op a b -> "(" ++ pretty op ++ " " ++ pretty a ++ " " ++ pretty b ++ ")" 73 | where 74 | unwrap (VarIdent name) = name 75 | prettyMatchClause (pattern, body) = "[" ++ pretty pattern ++ " " ++ pretty body ++ "]" 76 | 77 | 78 | instance Pretty BinOp where 79 | pretty Add = "+" 80 | pretty Sub = "-" 81 | pretty Mul = "*" 82 | pretty Div = "/" 83 | -- pretty Mod = "%" 84 | 85 | 86 | instance Pretty MonoType where 87 | pretty monoType = case renumber $ PolyType [] monoType of 88 | PolyType (_:_) _ -> "Error renumbering type variables" 89 | PolyType [] (TVar (TVarIdent n)) -> "τ" ++ subscript n 90 | PolyType [] (TLam argTypes retType) -> "(" ++ intercalate ", " (map pretty argTypes) ++ ") → " ++ pretty retType 91 | PolyType [] (TApp name types) -> unwords $ name : map pretty types 92 | 93 | 94 | instance Pretty PolyType where 95 | pretty polyType = case renumber polyType of 96 | (PolyType idents monoType) -> "∀ " ++ unwords (map prettyIdent idents) ++ ". " ++ pretty monoType 97 | where 98 | prettyIdent (TVarIdent ident) = "τ" ++ subscript ident 99 | 100 | 101 | -- | Renumbers all the type identifiers to make them easier to read 102 | renumber :: PolyType -> PolyType 103 | renumber (PolyType idents monoType) = PolyType (map (identMap !) idents) $ go identMap monoType 104 | where 105 | free = Set.toList $ freeVars monoType `Set.difference` Set.fromList idents 106 | identMap = Map.fromList $ zip (free ++ idents) (map TVarIdent [1..]) 107 | go :: Map TVarIdent TVarIdent -> MonoType -> MonoType 108 | go identMap (TVar ident) = TVar $ identMap ! ident 109 | go identMap (TLam args res) = TLam (map (go identMap) args) (go identMap res) 110 | go identMap (TApp name args) = TApp name $ map (go identMap) args 111 | 112 | 113 | instance Pretty LL.Expr where 114 | pretty expr = case expr of 115 | LL.Num n -> show n 116 | LL.Plus a b -> prettyOp "+" [a, b] 117 | LL.Minus a b -> prettyOp "-" [a, b] 118 | LL.Mult a b -> prettyOp "*" [a, b] 119 | LL.Divide a b -> prettyOp "/" [a, b] 120 | LL.If0 c t f -> prettyOp "if0" [c, t, f] 121 | LL.Let name value body -> "(let ["++name++" "++pretty value++"] "++pretty body++")" 122 | LL.Ref name -> name 123 | LL.App fName args -> prettyOp fName args 124 | LL.AppClos fn args -> prettyOp (pretty fn) args 125 | LL.NewClos fName values -> "(clos "++fName++" ["++unwords (map pretty values)++"])" 126 | LL.GetEnv _ index -> "(get-env "++show index++")" 127 | where 128 | prettyOp op args = "(" ++ unwords (op : map pretty args) ++ ")" 129 | 130 | 131 | instance Pretty LL.Def where 132 | pretty (LL.ClosureDef name _ argNames body) = "(closure-body ("++unwords (name:argNames)++")\n "++pretty body++")" 133 | 134 | 135 | instance Pretty LL.Prog where 136 | pretty (LL.Prog defs expr) = "(prog\n"++defBlock++"\n "++pretty expr++")\n" 137 | where 138 | defBlock = unlines $ map (" " ++) $ lines $ intercalate "\n" (map pretty defs) 139 | 140 | 141 | instance Pretty A.Expr where 142 | pretty expr = case expr of 143 | A.Num n -> show n 144 | A.BinOp op a b -> prettyOp (pretty op) [a, b] 145 | A.If0 c t f -> prettyOp "if0" [A.Atomic c, t, f] 146 | A.Let name value body -> "(let ["++name++" "++pretty value++"] "++pretty body++")" 147 | A.App fName args -> prettyOp fName args 148 | A.AppClos fn args -> prettyOp (pretty fn) args 149 | A.NewClos fName values -> "(clos "++fName++" ["++unwords (map pretty values)++"])" 150 | A.Atomic aExpr -> pretty aExpr 151 | where 152 | prettyOp op args = "(" ++ unwords (op : map pretty args) ++ ")" 153 | 154 | 155 | instance Pretty A.AExpr where 156 | pretty expr = case expr of 157 | A.Ref name -> name 158 | A.GetEnv _ index -> "(get-env "++show index++")" 159 | 160 | 161 | instance Pretty A.BinOp where 162 | pretty op = case op of 163 | A.Add -> "+" 164 | A.Sub -> "-" 165 | A.Mul -> "*" 166 | A.Div -> "/" 167 | 168 | 169 | instance Pretty A.Def where 170 | pretty (A.ClosureDef name _ argNames body) = "(closure-body ("++unwords (name:argNames)++")\n "++pretty body++")" 171 | 172 | 173 | instance Pretty A.Prog where 174 | pretty (A.Prog defs expr) = "(prog\n"++defBlock++"\n "++pretty expr++")\n" 175 | where 176 | defBlock = unlines $ map (" " ++) $ lines $ intercalate "\n" (map pretty defs) 177 | -------------------------------------------------------------------------------- /src/RuntimeDefs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, NamedFieldPuns, OverloadedStrings, TupleSections #-} 2 | 3 | module RuntimeDefs where 4 | 5 | import qualified Control.Monad as M ( void, zipWithM_ ) 6 | 7 | import LLVM.AST ( Definition(GlobalDefinition), Name, Operand) 8 | import qualified LLVM.AST.IntegerPredicate as L (IntegerPredicate(EQ)) 9 | -- import LLVM.AST.DataLayout 10 | -- import LLVM.AST.FunctionAttribute 11 | -- import qualified LLVM.AST.IntegerPredicate as IPred 12 | import LLVM.AST.Global 13 | import qualified LLVM.AST.Constant as C 14 | -- import LLVM.AST.AddrSpace (AddrSpace(AddrSpace)) 15 | -- import LLVM.AST.Linkage (Linkage(Private)) 16 | import LLVM.AST.Type 17 | -- import LLVM.Context 18 | -- import LLVM.Module hiding (Module) 19 | import LLVM.AST.Operand ( Operand(ConstantOperand) ) 20 | 21 | import LLVM.IRBuilder.Module 22 | import LLVM.IRBuilder.Monad 23 | import LLVM.IRBuilder.Instruction 24 | import LLVM.IRBuilder.Constant hiding (int16) 25 | 26 | 27 | -- import Fresh 28 | 29 | data Runtime = Runtime 30 | { printf :: Operand 31 | , exit :: Operand 32 | -- | runtime.c defs 33 | , layout :: Type 34 | , header :: Type 35 | , scopeCell :: Type 36 | , allObjects :: Operand 37 | , numObjects :: Operand 38 | , inScope :: Operand 39 | , allocate :: Operand 40 | , runGC :: Operand 41 | , markObjects :: Operand 42 | , printObject :: Operand 43 | , printScope :: Operand 44 | -- | Local defs 45 | , pushScopeDef :: Operand 46 | , popScopeDef :: Operand 47 | , setSlotDef :: Operand 48 | , getSlotDef :: Operand 49 | } deriving (Eq, Ord, Show) 50 | 51 | 52 | globalNull :: MonadModuleBuilder m => Name -> Type -> m Operand 53 | globalNull name _ty = global name ptr $ C.Null ptr 54 | 55 | externGlobal :: MonadModuleBuilder m => Name -> Type -> m Operand 56 | externGlobal name ty = do 57 | emitDefn $ GlobalDefinition globalVariableDefaults 58 | { name=name 59 | , type'=ty 60 | } 61 | return $ ConstantOperand $ C.GlobalReference name 62 | 63 | int16 :: Integer -> Operand 64 | int16 = ConstantOperand . C.Int 16 65 | 66 | 67 | defineRuntime :: MonadModuleBuilder m => m Runtime 68 | defineRuntime = do 69 | printf <- externVarArgs "printf" [ptr] i32 70 | exit <- extern "exit" [i32] void 71 | malloc <- extern "malloc" [i32] ptr 72 | free <- extern "free" [ptr] void 73 | 74 | layout <- defineLayout 75 | header <- defineHeader layout 76 | scopeCell <- defineScopeCell header 77 | allObjects <- externGlobal "__all_objects" ptr 78 | numObjects <- externGlobal "__num_objects" i64 79 | inScope <- globalNull "__in_scope" scopeCell 80 | allocate <- extern "__allocate" [i64] ptr 81 | runGC <- extern "__run_gc" [] void 82 | markObjects <- extern "__mark_heap_objects" [ptr] void 83 | printObject <- extern "__print_object" [ptr] void 84 | printScope <- extern "__print_scope" [] void 85 | pushScope <- definePushScope malloc header scopeCell inScope 86 | popScope <- definePopScope scopeCell inScope printf exit free 87 | setSlot <- defineSetSlot header 88 | getSlot <- defineGetSlot header 89 | 90 | return $ Runtime 91 | { printf = printf 92 | , exit = exit 93 | , layout = layout 94 | , header = header 95 | , scopeCell = scopeCell 96 | , allObjects = allObjects 97 | , numObjects = numObjects 98 | , inScope = inScope 99 | , allocate = allocate 100 | , runGC = runGC 101 | , markObjects = markObjects 102 | , printObject = printObject 103 | , printScope = printScope 104 | , pushScopeDef = pushScope 105 | , popScopeDef = popScope 106 | , setSlotDef = setSlot 107 | , getSlotDef = getSlot 108 | } 109 | 110 | defineLayout :: MonadModuleBuilder m => m Type 111 | defineLayout = typedef "__layout" $ Just $ StructureType False [i16, i16, i16, i16] 112 | 113 | defineHeader :: MonadModuleBuilder m => Type -> m Type 114 | defineHeader layout = typedef name $ Just $ StructureType False [ptr, layout] 115 | where 116 | name = "__heap_object" 117 | ref = NamedTypeReference name 118 | 119 | defineScopeCell :: MonadModuleBuilder m => Type -> m Type 120 | defineScopeCell header = typedef name $ Just $ StructureType False [ptr, ptr] 121 | where 122 | name = "__scope_cell" 123 | ref = NamedTypeReference name 124 | 125 | definePushScope :: MonadModuleBuilder m => Operand -> Type -> Type -> Operand -> m Operand 126 | definePushScope malloc header scopeCell inScope = function "__push_scope" [(ptr, "obj")] void pushScope 127 | where 128 | pushScope [obj] = do 129 | oldHead <- load ptr inScope 8 130 | cell <- call (FunctionType ptr [i32] False) malloc [(int32 16, [])] >>= flip bitcast ptr 131 | cellObj <- gep header cell [int64 0, int32 0] 132 | store cellObj 8 obj 133 | cellPrev <- gep scopeCell cell [int64 0, int32 1] 134 | store cellPrev 8 oldHead 135 | store inScope 8 cell 136 | retVoid 137 | 138 | pushScope :: (MonadIRBuilder m, MonadModuleBuilder m) => Runtime -> Operand -> m () 139 | pushScope Runtime{pushScopeDef} obj = M.void $ call (FunctionType void [ptr] False) pushScopeDef [(obj, [])] 140 | 141 | definePopScope :: MonadModuleBuilder m 142 | => Type -- ^ scopeCell struct type 143 | -> Operand -- ^ inScope pointer to list of in scope cells 144 | -> Operand -- ^ printf 145 | -> Operand -- ^ exit 146 | -> Operand -- ^ free 147 | -> m Operand 148 | definePopScope scopeCell inScope printf exit free = function "__pop_scope" [] void popScope 149 | where 150 | popScope [] = do 151 | err <- freshName "error" 152 | ok <- freshName "ok" 153 | -- if(inScope == NULL) 154 | oldHead <- load ptr inScope 8 155 | cond <- icmp L.EQ oldHead (ConstantOperand $ C.Null ptr) 156 | condBr cond err ok 157 | 158 | -- error block 159 | emitBlockStart err 160 | errString <- globalStringPtr "Runtime Error: No objects in scope to remove!\n" "pop_scope_error_msg" 161 | call (FunctionType i32 [ptr] True) printf [(ConstantOperand errString, [])] 162 | call (FunctionType void [i32] False) exit [(int32 (-1), [])] 163 | unreachable 164 | 165 | -- ok block 166 | emitBlockStart ok 167 | -- inScope = inScope->prev 168 | -- free(oldHead) 169 | prevPtr <- gep scopeCell oldHead [int64 0, int32 1] 170 | prev <- load ptr prevPtr 8 171 | store inScope 8 prev 172 | -- oldHeadI8 <- bitcast oldHead ptr 173 | call (FunctionType void [ptr] False) free [(oldHead, [])] 174 | retVoid 175 | 176 | popScope :: (MonadIRBuilder m, MonadModuleBuilder m) => Runtime -> m () 177 | popScope Runtime{popScopeDef} = M.void $ call (FunctionType void [] False) popScopeDef [] 178 | 179 | defineSetSlot :: MonadModuleBuilder m => Type -> m Operand 180 | defineSetSlot header = function "__set_object_slot" [(ptr, "obj"), (i64, "index"), (ptr, "value")] void body 181 | where 182 | body [obj, index, value] = do 183 | objSucc <- gep header obj [int64 1] 184 | values <- bitcast objSucc ptr 185 | slot <- gep ptr values [index] 186 | store slot 8 value 187 | retVoid 188 | 189 | setSlot :: (MonadIRBuilder m, MonadModuleBuilder m) => Runtime -> Operand -> Operand -> Operand -> m Operand 190 | setSlot Runtime{setSlotDef} obj index value = call (FunctionType void [ptr, i64, ptr] False) setSlotDef [(obj, []), (index, []), (value, [])] 191 | 192 | defineGetSlot :: MonadModuleBuilder m => Type -> m Operand 193 | defineGetSlot header = function "__get_object_slot" [(ptr, "obj"), (i64, "index")] ptr body 194 | where 195 | body [obj, index] = do 196 | objSucc <- gep header obj [int64 1] 197 | values <- bitcast objSucc ptr 198 | slot <- gep ptr values [index] 199 | value <- load ptr slot 8 200 | ret value 201 | 202 | getSlot :: (MonadIRBuilder m, MonadModuleBuilder m) => Runtime -> Operand -> Operand -> m Operand 203 | getSlot Runtime{getSlotDef} obj index = call (FunctionType ptr [ptr, i64] False) getSlotDef [(obj, []), (index, [])] 204 | 205 | 206 | -- | Object creation routines 207 | 208 | createInt :: (MonadIRBuilder m, MonadModuleBuilder m) => Runtime -> Operand -> m Operand 209 | createInt runtime@Runtime{header, allocate} value = do 210 | obj <- call (FunctionType ptr [i64] False) allocate [(int64 8, [])] 211 | ptrValue <- inttoptr value ptr 212 | setSlot runtime obj (int64 0) ptrValue 213 | return obj 214 | 215 | getInt :: (MonadIRBuilder m, MonadModuleBuilder m) => Runtime -> Operand -> m Operand 216 | getInt runtime obj = getSlot runtime obj (int64 0) >>= flip ptrtoint i64 217 | 218 | createClosure :: (MonadIRBuilder m, MonadModuleBuilder m) 219 | => Runtime -- ^ Runtime 220 | -> Operand -- ^ Function pointer 221 | -> [Operand] -- ^ Pointers 222 | -> [Operand] -- ^ Values 223 | -> m Operand 224 | createClosure Runtime{allocate, header} fn pointers values = do 225 | let size = fromIntegral $ 8 * (length pointers + length values + 1) 226 | obj <- call (FunctionType ptr [i64] False) allocate [(int64 size, [])] 227 | -- set num pointers 228 | numPointersAddr <- gep header obj [int64 0, int32 1, int32 2] 229 | store numPointersAddr 8 (int16 $ fromIntegral $ length pointers) 230 | -- set slots 231 | array <- gep header obj [int64 1] >>= flip bitcast ptr 232 | M.zipWithM_ (storePtr array) [0..] pointers 233 | M.zipWithM_ (storeValue array) [fromIntegral $ length pointers..] values 234 | _ <- storePtr array (fromIntegral $ length pointers + length values) fn 235 | return obj 236 | where 237 | storePtr array index value = bitcast value ptr >>= storeArray array index 238 | 239 | storeValue array index value = inttoptr value ptr >>= storeArray array index 240 | 241 | storeArray array index value = do 242 | addr <- gep ptr array [int64 index] 243 | store addr 8 value 244 | 245 | callClosure :: (MonadIRBuilder m, MonadModuleBuilder m) 246 | => Runtime -- ^ Runtime 247 | -> Operand -- ^ Closure 248 | -> [Operand] -- ^ Arguments 249 | -> m Operand 250 | callClosure runtime@Runtime{header} closure args = do 251 | envSize <- objectSize closure 252 | fnSlot <- sub envSize (int16 1) >>= flip zext i64 253 | -- let numArgs = 1 + length args 254 | fnPtr <- getSlot runtime closure fnSlot >>= flip bitcast ptr 255 | let fnType = FunctionType ptr (replicate (length args + 1) ptr) False 256 | call fnType fnPtr $ (closure, []) : map (,[]) args 257 | where 258 | objectSize obj = do 259 | loc <- gep header obj [int64 0, int32 1, int32 1] 260 | load i16 loc 2 261 | -------------------------------------------------------------------------------- /src/Scope.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | 3 | module Scope where 4 | 5 | import Data.Set (Set) 6 | 7 | class Scope e i where 8 | freeVars :: e -> Set i 9 | 10 | class Substitute e where 11 | substitute :: (e -> Maybe e) -> e -> e 12 | -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | 3 | module Types where 4 | 5 | import qualified Data.Set as Set 6 | 7 | import Scope 8 | 9 | newtype TVarIdent = TVarIdent Int deriving (Show, Eq, Ord) 10 | 11 | data MonoType 12 | = TVar TVarIdent 13 | | TLam [MonoType] MonoType 14 | | TApp String [MonoType] 15 | deriving (Show, Eq, Ord) 16 | 17 | 18 | data PolyType 19 | = PolyType [TVarIdent] MonoType 20 | deriving (Show, Eq, Ord) 21 | 22 | 23 | instance Scope MonoType TVarIdent where 24 | freeVars monoType = case monoType of 25 | TVar ident -> Set.singleton ident 26 | TLam argTypes retType -> Set.unions $ map freeVars (retType:argTypes) 27 | TApp _ args -> Set.unions $ map freeVars args 28 | 29 | instance Scope PolyType TVarIdent where 30 | freeVars (PolyType idents monoType) = foldr Set.delete (freeVars monoType) idents 31 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-20.21 # 18.28 #9.21 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: 43 | - git: https://github.com/llvm-hs/llvm-hs 44 | commit: 80e0de0f96eb78288c88fda0eaba0f7cf5d38a30 # 423220bffac4990d019fc088c46c5f25310d5a33 45 | subdirs: 46 | - llvm-hs 47 | - llvm-hs-pure 48 | 49 | #- git: https://github.com/llvm-hs/llvm-hs-pretty.git 50 | # commit: 655ff4d47b3a584b4c9a5863f6121b954825920c 51 | 52 | # Override default flag values for local packages and extra-deps 53 | # flags: {} 54 | 55 | # Extra package databases containing global packages 56 | # extra-package-dbs: [] 57 | 58 | # Control whether we use the GHC we find on the path 59 | # system-ghc: true 60 | # 61 | # Require a specific version of stack, using version ranges 62 | # require-stack-version: -any # Default 63 | # require-stack-version: ">=1.6" 64 | # 65 | # Override the architecture used by stack, especially useful on Windows 66 | # arch: i386 67 | # arch: x86_64 68 | # 69 | # Extra directories used by stack for building 70 | # extra-include-dirs: [/path/to/dir] 71 | # extra-lib-dirs: [/path/to/dir] 72 | # 73 | # Allow a newer minor version of GHC than the snapshot specifies 74 | # compiler-check: newer-minor 75 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | commit: 80e0de0f96eb78288c88fda0eaba0f7cf5d38a30 9 | git: https://github.com/llvm-hs/llvm-hs 10 | name: llvm-hs 11 | pantry-tree: 12 | sha256: 3b5fa30d13f930135b45d0eb18ba7b7598dda33800515f251ed00b13498121e9 13 | size: 12716 14 | subdir: llvm-hs 15 | version: 15.0.0 16 | original: 17 | commit: 80e0de0f96eb78288c88fda0eaba0f7cf5d38a30 18 | git: https://github.com/llvm-hs/llvm-hs 19 | subdir: llvm-hs 20 | - completed: 21 | commit: 80e0de0f96eb78288c88fda0eaba0f7cf5d38a30 22 | git: https://github.com/llvm-hs/llvm-hs 23 | name: llvm-hs-pure 24 | pantry-tree: 25 | sha256: b512f9e5f8f2b3e3a06bad2fa5ff053a83d817798c7efcd47e254e68c842169d 26 | size: 2712 27 | subdir: llvm-hs-pure 28 | version: 15.0.0 29 | original: 30 | commit: 80e0de0f96eb78288c88fda0eaba0f7cf5d38a30 31 | git: https://github.com/llvm-hs/llvm-hs 32 | subdir: llvm-hs-pure 33 | snapshots: 34 | - completed: 35 | sha256: 401a0e813162ba62f04517f60c7d25e93a0f867f94a902421ebf07d1fb5a8c46 36 | size: 650044 37 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/21.yaml 38 | original: lts-20.21 39 | -------------------------------------------------------------------------------- /test/ANormSpec.hs: -------------------------------------------------------------------------------- 1 | module ANormSpec (aNormTests) where 2 | 3 | import qualified Data.Map as Map 4 | import qualified Data.Set as Set 5 | import Test.Tasty 6 | import Test.Tasty.HUnit 7 | 8 | import qualified ANorm as A 9 | import Fresh (evalFresh) 10 | import qualified LowLevel as LL 11 | import Parsing (parse) 12 | 13 | runNormalization :: LL.Expr -> A.Expr 14 | runNormalization input = evalFresh (A.aNormalizeExpr input) Map.empty 15 | 16 | checkNormalization :: LL.Expr -> A.Expr -> Assertion 17 | checkNormalization input expected = runNormalization input @?= expected 18 | 19 | emitLL :: String -> LL.Prog 20 | emitLL input = LL.runConvert (either error id $ parse "" input) Set.empty 21 | 22 | mainBody :: LL.Prog -> LL.Expr 23 | mainBody (LL.Prog defs body) = body 24 | 25 | aNormTests :: TestTree 26 | aNormTests = testGroup "A Normalization Tests" 27 | [ testCase "plus" $ checkNormalization 28 | (LL.Plus (LL.Num 1) (LL.Num 2)) 29 | (A.Let "_add_a_0" (A.Num 1) 30 | (A.Let "_add_b_0" (A.Num 2) 31 | (A.BinOp A.Add (A.Ref "_add_a_0") (A.Ref "_add_b_0")))) 32 | 33 | , testCase "binding order" $ checkNormalization 34 | (LL.App "external" [LL.Num 0, LL.Ref "one", LL.Num 2]) 35 | (A.Let "_arg0_0" (A.Num 0) 36 | (A.Let "_arg2_0" (A.Num 2) 37 | (A.App "external" [A.Ref "_arg0_0", A.Ref "one", A.Ref "_arg2_0"]))) 38 | 39 | , testCase "nested" $ checkNormalization 40 | (LL.Plus (LL.Plus (LL.Ref "one") (LL.Num 2)) (LL.Plus (LL.Num 3) (LL.Ref "four"))) 41 | (A.Let "_add_a_0" (A.Let "_add_b_0" (A.Num 2) 42 | (A.BinOp A.Add (A.Ref "one") (A.Ref "_add_b_0"))) 43 | (A.Let "_add_b_1" (A.Let "_add_a_1" (A.Num 3) 44 | (A.BinOp A.Add (A.Ref "_add_a_1") (A.Ref "four"))) 45 | (A.BinOp A.Add (A.Ref "_add_a_0") (A.Ref "_add_b_1")))) 46 | 47 | , testCase "closure" $ checkNormalization 48 | (LL.AppClos (LL.NewClos "_f0" []) [LL.Num 7]) 49 | (A.Let "_clos_0" (A.NewClos "_f0" []) (A.Let "_arg0_0" (A.Num 7) (A.AppClos (A.Ref "_clos_0") [A.Ref "_arg0_0"]))) 50 | 51 | , let input = LL.Prog [LL.ClosureDef "func" "_env" ["n"] (LL.Plus (LL.Ref "n") (LL.Num 5))] (LL.App "func" [LL.Num 1]) 52 | expected = A.Prog [A.ClosureDef "func" "_env" ["n"] (A.Let "_add_b_0" (A.Num 5) (A.BinOp A.Add (A.Ref "n") (A.Ref "_add_b_0")))] 53 | (A.Let "_arg0_0" (A.Num 1) (A.App "func" [A.Ref "_arg0_0"])) 54 | in testCase "prog" $ evalFresh (A.aNormalizeProg input) Map.empty @?= expected 55 | ] -------------------------------------------------------------------------------- /test/ExecutionSpec.hs: -------------------------------------------------------------------------------- 1 | module ExecutionSpec (findExecutionTests) where 2 | 3 | import qualified Data.ByteString.Lazy as BL 4 | import System.FilePath (takeBaseName, replaceExtension) 5 | import Test.Tasty 6 | import Test.Tasty.Golden 7 | 8 | import CmdLine 9 | import CmdLineArgs 10 | 11 | 12 | testArgs :: Args 13 | testArgs = defaultArgs { optimizationFlag = Just "-O3", debugRuntime = False } 14 | 15 | 16 | goldenTest :: String -> TestTree 17 | goldenTest tlFile = goldenVsString (takeBaseName tlFile) goldFile $ do 18 | either error BL.fromStrict <$> produceOutput args 19 | where 20 | goldFile = replaceExtension tlFile ".gold" 21 | args = testArgs { inputFile = Just tlFile } 22 | 23 | 24 | findExecutionTests :: IO TestTree 25 | findExecutionTests = do 26 | tlFiles <- findByExtension [".tl"] "test/golden" 27 | return $ testGroup "Golden Tests" [goldenTest tlFile | tlFile <- tlFiles] -------------------------------------------------------------------------------- /test/LLSpec.hs: -------------------------------------------------------------------------------- 1 | module LLSpec (lowLevelTests) where 2 | 3 | import qualified Data.Set as Set 4 | import Test.Tasty 5 | import Test.Tasty.HUnit 6 | 7 | import LowLevel 8 | import Parsing (parse) 9 | 10 | emitLL :: String -> Prog 11 | emitLL input = runConvert (either error id $ parse "test_input" input) Set.empty 12 | 13 | checkLowLevel :: String -> Prog -> Assertion 14 | checkLowLevel input expected = emitLL input @?= expected 15 | 16 | lowLevelTests :: TestTree 17 | lowLevelTests = testGroup "Low Level Tests" 18 | [ testCase "letrec" $ checkLowLevel 19 | "(letrec [x x] x)" 20 | (Prog 21 | [ClosureDef "_f0" "_env" ["x"] 22 | (AppClos (Ref "x") [Ref "x"])] 23 | (Let "x" (NewClos "_f0" []) 24 | (AppClos (Ref "x") [Ref "x"]))) 25 | , testCase "lambda" $ checkLowLevel 26 | "(lambda (x y) y)" 27 | (Prog 28 | [ClosureDef "_f0" "_env" ["x", "y"] (Ref "y")] 29 | (NewClos "_f0" [])) 30 | , testCase "lambda shadowing" $ checkLowLevel 31 | "(lambda (x) (lambda (x) x))" 32 | (Prog 33 | [ ClosureDef "_f0" "_env" ["x"] (NewClos "_f1" []) 34 | , ClosureDef "_f1" "_env" ["x"] (Ref "x") 35 | ] 36 | (NewClos "_f0" [])) 37 | , testCase "lambda nested reference" $ checkLowLevel 38 | "(lambda (x) (lambda (y) x))" 39 | (Prog 40 | [ ClosureDef "_f0" "_env" ["x"] (NewClos "_f1" [Ref "x"]) 41 | , ClosureDef "_f1" "_env" ["y"] (GetEnv "_env" 0) 42 | ] 43 | (NewClos "_f0" [])) 44 | , testCase "lambda double nested reference" $ checkLowLevel 45 | "(lambda (x) (lambda (y) (lambda (z) (+ x y))))" 46 | (Prog 47 | [ ClosureDef "_f0" "_env" ["x"] (NewClos "_f1" [Ref "x"]) 48 | , ClosureDef "_f1" "_env" ["y"] (NewClos "_f2" [GetEnv "_env" 0, Ref "y"]) 49 | , ClosureDef "_f2" "_env" ["z"] (Plus (GetEnv "_env" 0) (GetEnv "_env" 1)) 50 | ] 51 | (NewClos "_f0" [])) 52 | -- , testCase "struct" $ checkLowLevel 53 | -- "(struct Bool [True] [False]) True" 54 | -- (Prog 55 | -- [ StructDef 56 | -- ] 57 | -- (Obj )) 58 | ] -------------------------------------------------------------------------------- /test/ParseLispSpec.hs: -------------------------------------------------------------------------------- 1 | module ParseLispSpec (parseLispTests) where 2 | 3 | import Data.Either 4 | import Test.Tasty 5 | import Test.Tasty.HUnit 6 | import Text.Megaparsec 7 | 8 | import ParseLisp 9 | 10 | checkParser :: (Eq a, Show a) => Parser a -> String -> a -> Assertion 11 | checkParser parser input expected = result @?= Right expected 12 | where 13 | result = parse parser "testInput" input 14 | 15 | parseLispTests :: TestTree 16 | parseLispTests = testGroup "Lisp Parser Tests" 17 | [ testCase "parse num" $ checkParser expression "12" (Number 12) 18 | , testCase "parse num" $ checkParser integerLit "-4" (-4) 19 | , testCase "parse float" $ checkParser expression "123.3e-12" (Float 123.3e-12) 20 | , testCase "parse symbol" $ checkParser expression "-" (Symbol "-") 21 | , testCase "parse symbol" $ checkParser expression "\"asdf\"" (String "asdf") 22 | , testCase "parse symbol" $ checkParser expression "( + 3 -4 )" (List [Symbol "+", Number 3, Number (-4)]) 23 | , testCase "comment" $ checkParser wholeFile ";a\n12\n;b\n" [Number 12] 24 | , testCase "block comment" $ checkParser wholeFile "#;(asd {} asd)12#;()" [Number 12] 25 | , testCase "multiple nums" $ checkParser wholeFile "12 13" [Number 12, Number 13] 26 | , testCase "multiple expressions" $ checkParser wholeFile "(f 6)\n(len \"str\")" [List [Symbol "f", Number 6], List [Symbol "len", String "str"]] 27 | ] -------------------------------------------------------------------------------- /test/RuntimeSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns, OverloadedStrings #-} 2 | 3 | module RuntimeSpec (makeRuntimeTests) where 4 | 5 | import qualified Control.Monad as M (void) 6 | import qualified Data.ByteString.UTF8 as BSU 7 | import System.Directory (createDirectoryIfMissing) 8 | import Test.Tasty 9 | import Test.Tasty.HUnit 10 | import Text.Regex.PCRE 11 | 12 | import LLVM.AST (Module) 13 | import LLVM.AST.Type 14 | import LLVM.AST.Operand 15 | import LLVM.IRBuilder.Module 16 | import LLVM.IRBuilder.Monad 17 | import LLVM.IRBuilder.Instruction 18 | import LLVM.IRBuilder.Constant 19 | 20 | import CmdLine 21 | import CmdLineArgs 22 | import CodegenMonad 23 | import RuntimeDefs 24 | 25 | 26 | testArgs :: Args 27 | testArgs = defaultArgs { optimizationFlag = Just "-O3", debugRuntime = False } 28 | 29 | 30 | printObj :: (MonadIRBuilder m, MonadModuleBuilder m) => Runtime -> Operand -> m () 31 | printObj Runtime{header, printObject} obj = do 32 | objPtr <- bitcast obj ptr 33 | _ <- call (FunctionType void [ptr] False) printObject [(objPtr, [])] 34 | return () 35 | 36 | printPtr :: (MonadIRBuilder m, MonadModuleBuilder m) => Runtime -> Operand -> m () 37 | printPtr Runtime{printf} value = do 38 | formatString <- globalStringPtr "%p\n" "ptr_fmt_string" 39 | call (FunctionType i32 [ptr] True) printf [(ConstantOperand formatString, []), (value, [])] 40 | return () 41 | 42 | callPrintScope :: (MonadIRBuilder m, MonadModuleBuilder m) => Runtime -> m () 43 | callPrintScope Runtime{printScope} = do 44 | _ <- call (FunctionType void [] False) printScope [] 45 | return () 46 | 47 | 48 | runtimeTest :: String -> String -> IRBuilderT ModuleBuilder () -> TestTree 49 | runtimeTest name expected prog = testCase name $ do 50 | createDirectoryIfMissing True dirname 51 | output <- runModule $ buildModule "testing-module" $ wrapMain prog 52 | assertBool ("expected: " ++ show expected ++ "\n but got: " ++ show output) $ matches output 53 | where 54 | dirname = "tmp-test" 55 | exeFile = dirname ++ "/" ++ name ++ ".out" 56 | 57 | wrapMain :: MonadModuleBuilder m => IRBuilderT m a -> m () 58 | wrapMain body = M.void $ function "main" [] i32 $ \[] -> body >> ret (int32 0) 59 | 60 | matches :: String -> Bool 61 | matches actual = actual =~ expected 62 | -- matches = match $ makeRegexOpts compExtended defaultExecOpt expected 63 | 64 | runModule :: Module -> IO String 65 | runModule llvmModule = do 66 | let args = testArgs { inputFile = Just name } 67 | llvm <- BSU.fromString <$> serialize llvmModule 68 | result <- optimize args llvm >>= assemble "obj" args >>= link args exeFile >>= execute 69 | return $ BSU.toString result 70 | 71 | 72 | makeRuntimeTests :: IO TestTree 73 | makeRuntimeTests = do 74 | compileRuntimeC testArgs 75 | return $ testGroup "Runtime Tests" 76 | [ let expected = "^obj@.*<0x0,0000\\|0001\\|0000>\\[0xa431\\]\n$" 77 | in runtimeTest "createInt" expected $ do 78 | runtime <- defineRuntime 79 | n <- createInt runtime (int64 0xa431) 80 | printObj runtime n 81 | 82 | , runtimeTest "getInt" "^0xb241\n$" $ do 83 | runtime <- defineRuntime 84 | a <- createInt runtime (int64 0xb241) 85 | n <- getInt runtime a 86 | printPtr runtime n 87 | 88 | , let expected = "^obj@(.*)<.*>\\[0x6dfa\\]\n\ 89 | \\\[\\1\\]\n$" 90 | in runtimeTest "pushScope" expected $ do 91 | runtime <- defineRuntime 92 | a <- createInt runtime (int64 0x6dfa) 93 | pushScope runtime a 94 | printObj runtime a 95 | callPrintScope runtime 96 | 97 | , let expected = "^obj@(.*)<0x0,.*>\\[0xfa72\\]\n\ 98 | \obj@(.*)<\\1,.*>\\[0x3401\\]\n\ 99 | \\\[\\2\\]$" 100 | in runtimeTest "popScope" expected $ do 101 | runtime <- defineRuntime 102 | a <- createInt runtime (int64 0xfa72) 103 | b <- createInt runtime (int64 0x3401) 104 | pushScope runtime b 105 | pushScope runtime a 106 | popScope runtime 107 | printObj runtime a 108 | printObj runtime b 109 | callPrintScope runtime 110 | 111 | , runtimeTest "setSlot" "obj@.*<.*>\\[0xfe2f\\]\n$" $ do 112 | runtime <- defineRuntime 113 | a <- createInt runtime (int64 0x6af8) 114 | val <- inttoptr (int64 0xfe2f) ptr 115 | setSlot runtime a (int64 0) val 116 | printObj runtime a 117 | 118 | , runtimeTest "getSlot" "^0x762c\n$" $ do 119 | runtime <- defineRuntime 120 | a <- createInt runtime (int64 0x762c) 121 | val <- getSlot runtime a (int64 0) 122 | printPtr runtime val 123 | 124 | , let expected = "^obj@.*<0x0,0000\\|0004\\|0001>\\[0xefe4,0x3cd0,0x8d3d,0x897b\\]\n$" 125 | in runtimeTest "createClosure" expected $ do 126 | runtime <- defineRuntime 127 | f <- inttoptr (int64 0x897b) ptr 128 | p <- inttoptr (int64 0xefe4) ptr 129 | obj <- createClosure runtime f [p] [int64 0x3cd0, int64 0x8d3d] 130 | printObj runtime obj 131 | 132 | , let expected = "^obj@.*<.*,0000\\|0003\\|0001>\\[0xf330,0x8a2f,.*\\]\n$" 133 | in runtimeTest "callClosure" expected $ do 134 | runtime <- defineRuntime 135 | fn <- function "__test_closure_fn" [(ptr, "env")] void $ 136 | \[env] -> printObj runtime env >> retVoid 137 | p <- inttoptr (int64 0xf330) ptr 138 | clos <- createClosure runtime fn [p] [int64 0x8a2f] 139 | _ <- callClosure runtime clos [] 140 | return () 141 | 142 | , let expected = "^obj@(.*)<0x0,0000\\|0001\\|0000>\\[0xe0f5\\]\n\ 143 | \obj@(.*)<\\1,0000\\|0002\\|0001>\\[\\1,0x535c\\]\n\ 144 | \obj@(.*)<\\2,0001\\|0001\\|0000>\\[0x3c7b\\]\n\ 145 | \obj@(.*)<\\3,0001\\|0002\\|0001>\\[\\3,0x5ec7\\]\n\ 146 | \obj@(.*)<\\4,0001\\|0002\\|0001>\\[\\4,0xf40a\\]\n$" 147 | in runtimeTest "markObjects" expected $ do 148 | runtime@Runtime{markObjects} <- defineRuntime 149 | ep <- inttoptr (int64 0xe0f5) ptr 150 | dp <- inttoptr (int64 0x535c) ptr 151 | cp <- inttoptr (int64 0x3c7b) ptr 152 | bp <- inttoptr (int64 0x5ec7) ptr 153 | ap <- inttoptr (int64 0xf40a) ptr 154 | e <- createClosure runtime ep [] [] 155 | d <- createClosure runtime dp [e] [] 156 | c <- createClosure runtime cp [] [] 157 | b <- createClosure runtime bp [c] [] 158 | a <- createClosure runtime ap [b] [] 159 | call (FunctionType void [ptr] False) markObjects [(a, [])] 160 | printObj runtime e 161 | printObj runtime d 162 | printObj runtime c 163 | printObj runtime b 164 | printObj runtime a 165 | 166 | , let expected = "^obj@(.*)<0x0,0000\\|0001\\|0000>\\[0xe0f5\\]\n\ 167 | \obj@(.*)<\\1,0000\\|0001\\|0000>\\[0x3c7b\\]\n\ 168 | \obj@(.*)<\\2,0000\\|0002\\|0001>\\[\\2,0x5ec7\\]\n\ 169 | \obj@(.*)<\\3,0000\\|0002\\|0001>\\[\\3,0xf40a\\]\n\ 170 | \\\[\\1,\\4\\]\n$" 171 | in runtimeTest "runGC" expected $ do 172 | runtime@Runtime{runGC, printScope} <- defineRuntime 173 | ep <- inttoptr (int64 0xe0f5) ptr 174 | dp <- inttoptr (int64 0x535c) ptr 175 | cp <- inttoptr (int64 0x3c7b) ptr 176 | bp <- inttoptr (int64 0x5ec7) ptr 177 | ap <- inttoptr (int64 0xf40a) ptr 178 | e <- createClosure runtime ep [] [] 179 | d <- createClosure runtime dp [e] [] 180 | c <- createClosure runtime cp [] [] 181 | b <- createClosure runtime bp [c] [] 182 | a <- createClosure runtime ap [b] [] 183 | pushScope runtime a 184 | pushScope runtime e 185 | call (FunctionType void [] False) runGC [] 186 | printObj runtime e 187 | printObj runtime c 188 | printObj runtime b 189 | printObj runtime a 190 | call (FunctionType void [] False) printScope [] 191 | return () 192 | ] -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | import Test.Tasty 2 | 3 | import ANormSpec 4 | import ExecutionSpec 5 | import LLSpec 6 | import ParseLispSpec 7 | import RuntimeSpec 8 | 9 | main :: IO () 10 | main = putStrLn "" >> buildTests >>= defaultMain 11 | 12 | buildTests :: IO TestTree 13 | buildTests = do 14 | executionTests <- findExecutionTests 15 | runtimeTests <- makeRuntimeTests 16 | return $ testGroup "Tests" 17 | [ parseLispTests 18 | , lowLevelTests 19 | , aNormTests 20 | , runtimeTests 21 | , executionTests 22 | ] 23 | -------------------------------------------------------------------------------- /test/golden/add.gold: -------------------------------------------------------------------------------- 1 | 7 2 | -------------------------------------------------------------------------------- /test/golden/add.tl: -------------------------------------------------------------------------------- 1 | (+ 3 4) 2 | -------------------------------------------------------------------------------- /test/golden/arith.gold: -------------------------------------------------------------------------------- 1 | 7 2 | -------------------------------------------------------------------------------- /test/golden/arith.tl: -------------------------------------------------------------------------------- 1 | (- (/ (+ (* 3 5) 1) 2) 1) 2 | -------------------------------------------------------------------------------- /test/golden/closure.gold: -------------------------------------------------------------------------------- 1 | 12 2 | -------------------------------------------------------------------------------- /test/golden/closure.tl: -------------------------------------------------------------------------------- 1 | ( 2 | (let (n 5) 3 | (lambda (x) (+ n x))) 4 | 7 5 | ) 6 | -------------------------------------------------------------------------------- /test/golden/fact.gold: -------------------------------------------------------------------------------- 1 | 120 2 | -------------------------------------------------------------------------------- /test/golden/fact.tl: -------------------------------------------------------------------------------- 1 | (letrec (fact (lambda (n) 2 | (if0 n 3 | 1 4 | (* n (fact (- n 1)))))) 5 | (fact 5)) 6 | -------------------------------------------------------------------------------- /test/golden/if_simple.gold: -------------------------------------------------------------------------------- 1 | 9 2 | -------------------------------------------------------------------------------- /test/golden/if_simple.tl: -------------------------------------------------------------------------------- 1 | (if0 1 5 9) 2 | -------------------------------------------------------------------------------- /test/golden/if_tail.gold: -------------------------------------------------------------------------------- 1 | 5 2 | -------------------------------------------------------------------------------- /test/golden/if_tail.tl: -------------------------------------------------------------------------------- 1 | (let (f (lambda () 5)) 2 | (let (main (lambda () 3 | (if0 0 4 | (f) 5 | (f)))) 6 | (main))) 7 | -------------------------------------------------------------------------------- /test/golden/if_tail_nested.gold: -------------------------------------------------------------------------------- 1 | 2 2 | -------------------------------------------------------------------------------- /test/golden/if_tail_nested.tl: -------------------------------------------------------------------------------- 1 | (letrec (f (lambda (n) 2 | (if0 n 3 | (f (+ n 1)) 4 | (if0 (- n 1) 5 | (f (- n 1)) 6 | n)))) 7 | (f 2)) -------------------------------------------------------------------------------- /test/golden/lambda_double_nest.gold: -------------------------------------------------------------------------------- 1 | 4 2 | -------------------------------------------------------------------------------- /test/golden/lambda_double_nest.tl: -------------------------------------------------------------------------------- 1 | (let [f (lambda (x) 2 | (lambda (y) 3 | (lambda (z) (- x y))))] 4 | (((f 11) 7) 5)) -------------------------------------------------------------------------------- /test/golden/let.gold: -------------------------------------------------------------------------------- 1 | 9 2 | -------------------------------------------------------------------------------- /test/golden/let.tl: -------------------------------------------------------------------------------- 1 | (let (x 5) 2 | (+ x 4)) -------------------------------------------------------------------------------- /test/golden/letrec.gold: -------------------------------------------------------------------------------- 1 | 0 2 | -------------------------------------------------------------------------------- /test/golden/letrec.tl: -------------------------------------------------------------------------------- 1 | (letrec [f (lambda (x) (if0 x 0 (f (- x 1))))] 2 | (f 2)) -------------------------------------------------------------------------------- /test/golden/mutual_rec.gold: -------------------------------------------------------------------------------- 1 | 0 2 | -------------------------------------------------------------------------------- /test/golden/mutual_rec.tl: -------------------------------------------------------------------------------- 1 | ;(let (f (lambda (f g a b) (g f g (+ a b)))) 2 | ; (let (g (lambda (f g n) (if0 n 0 (f f g (- n 2) 1)))) 3 | ; (g f g 75000))) 4 | 0 5 | -------------------------------------------------------------------------------- /test/golden/nested_lambda.gold: -------------------------------------------------------------------------------- 1 | 11 2 | -------------------------------------------------------------------------------- /test/golden/nested_lambda.tl: -------------------------------------------------------------------------------- 1 | (let (mk-add (lambda (n) (lambda (x) (+ x n)))) 2 | (let (a1 (mk-add 1)) 3 | (let (a2 (lambda (x) (a1 (a1 x)))) 4 | (+ (a1 3) (a2 5))))) 5 | -------------------------------------------------------------------------------- /test/golden/tail.gold: -------------------------------------------------------------------------------- 1 | 4 2 | -------------------------------------------------------------------------------- /test/golden/tail.tl: -------------------------------------------------------------------------------- 1 | (let (sub (lambda (a b) (- a b))) 2 | (let (dec (lambda (n) (sub n 1))) 3 | (dec 5))) 4 | -------------------------------------------------------------------------------- /tutorial.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tyehle/llvm-lambda/5bd6501298f5ab6efc9654b0ed00749dd08dcc96/tutorial.pdf --------------------------------------------------------------------------------