├── tests ├── test004.out ├── test005.out ├── test010.out ├── test011.out ├── test014.out ├── test015.out ├── test016.out ├── test017.out ├── test018.out ├── test019.out ├── test020.out ├── test021.out ├── test022.out ├── test023.out ├── test024.out ├── test026.out ├── test027.out ├── test028.out ├── test029.out ├── test030.out ├── test031.out ├── test033.out ├── test001.out ├── test002.out ├── test006.out ├── test012.out ├── test003.out ├── test032.out ├── test008.out ├── test025.out ├── test008.tig ├── test026.tig ├── test009.out ├── test016.tig ├── test018.tig ├── test015.err ├── test016.err ├── test017.err ├── test017.tig ├── test019.err ├── test001.tig ├── test020.tig ├── test024.err ├── test026.err ├── test030.err ├── test004.tig ├── test005.tig ├── test020.err ├── test024.tig ├── test002.tig ├── test018.err ├── test023.err ├── test027.err ├── test021.err ├── test022.err ├── test004.err ├── test028.err ├── test031.err ├── test015.tig ├── test021.tig ├── test022.tig ├── test029.err ├── test014.tig ├── test019.tig ├── test027.tig ├── test031.tig ├── test033.tig ├── test006.tig ├── test029.tig ├── test010.tig ├── test030.tig ├── test025.tig ├── test023.tig ├── test028.tig ├── test032.tig ├── test011.tig ├── test009.tig ├── test002.err ├── test003.tig ├── test012.tig ├── test001.err ├── dune ├── test013.tig ├── test008.err ├── test007.tig ├── test007.out ├── test013.out ├── test005.err ├── test032.err ├── test025.err ├── test003.err ├── test014.err ├── test010.err ├── test011.err ├── test006.err ├── test033.err ├── test009.err ├── test012.err ├── test013.err ├── test007.err └── dune.inc ├── .gitignore ├── .ocp-indent ├── src ├── compile.mli ├── fmt.mli ├── typecheck.mli ├── dune ├── tabs.ml ├── irep.mli ├── fmt.ml ├── typing.ml ├── lexer.mll ├── parser.mly ├── main.ml ├── irep.ml ├── compile.ml └── typecheck.ml ├── test ├── good │ ├── print0.tig │ ├── assign-nil.tig │ ├── let-nil.tig │ ├── nested0.tig │ ├── lambdalift0.tig │ ├── for0.tig │ ├── for-escapes.tig │ ├── rec-nil.tig │ ├── rec3.tig │ ├── nil-cmp.tig │ ├── rec0.tig │ ├── nested1.tig │ ├── mutually-recfns.tig │ ├── rec1.tig │ ├── fact.tig │ ├── arr1.tig │ ├── nested2.tig │ ├── rec-types.tig │ ├── lambdalift1.tig │ ├── rec2.tig │ ├── queens.tig │ └── gc0.tig └── bad │ ├── rec0.tig │ └── rec1.tig ├── README ├── dune-project ├── Makefile ├── tools ├── dune ├── gen_tests.ml └── run_test.ml ├── LICENSE └── runtime ├── tiger_stdlib.c ├── runtime.c └── tiger_gc.c /tests/test004.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test005.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test010.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test011.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test014.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test015.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test016.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test017.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test018.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test019.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test020.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test021.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test022.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test023.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test024.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test026.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test027.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test028.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test029.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test030.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test031.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test033.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test001.out: -------------------------------------------------------------------------------- 1 | 24 -------------------------------------------------------------------------------- /tests/test002.out: -------------------------------------------------------------------------------- 1 | 42 -------------------------------------------------------------------------------- /tests/test006.out: -------------------------------------------------------------------------------- 1 | 42 -------------------------------------------------------------------------------- /tests/test012.out: -------------------------------------------------------------------------------- 1 | 123 -------------------------------------------------------------------------------- /tests/test003.out: -------------------------------------------------------------------------------- 1 | -1869596475 -------------------------------------------------------------------------------- /tests/test032.out: -------------------------------------------------------------------------------- 1 | 2004310016 -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _opam 2 | _build 3 | -------------------------------------------------------------------------------- /tests/test008.out: -------------------------------------------------------------------------------- 1 | Hello, World! 2 | -------------------------------------------------------------------------------- /tests/test025.out: -------------------------------------------------------------------------------- 1 | # GC roots: 2 2 | -------------------------------------------------------------------------------- /tests/test008.tig: -------------------------------------------------------------------------------- 1 | print("Hello, World!\n") -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | match_clause=4 2 | strict_with=auto -------------------------------------------------------------------------------- /tests/test026.tig: -------------------------------------------------------------------------------- 1 | /* ERR: illegal break */ 2 | break -------------------------------------------------------------------------------- /tests/test009.out: -------------------------------------------------------------------------------- 1 | # GC roots: 3 2 | # GC roots: 3 3 | 12 -------------------------------------------------------------------------------- /tests/test016.tig: -------------------------------------------------------------------------------- 1 | /* ERR: unknown function */ 2 | f(42) 3 | -------------------------------------------------------------------------------- /tests/test018.tig: -------------------------------------------------------------------------------- 1 | /* ERR: wrong arity */ 2 | printi(42, 56) 3 | -------------------------------------------------------------------------------- /src/compile.mli: -------------------------------------------------------------------------------- 1 | val program : Typing.program -> Irep.program 2 | -------------------------------------------------------------------------------- /src/fmt.mli: -------------------------------------------------------------------------------- 1 | val expression: Format.formatter -> Tabs.exp -> unit 2 | -------------------------------------------------------------------------------- /tests/test015.err: -------------------------------------------------------------------------------- 1 | error: test015.tig:5:10: unknown variable `y' 2 | -------------------------------------------------------------------------------- /tests/test016.err: -------------------------------------------------------------------------------- 1 | error: test016.tig:2:1: unknown function `f' 2 | -------------------------------------------------------------------------------- /tests/test017.err: -------------------------------------------------------------------------------- 1 | error: test017.tig:2:1: unknown type name `t' 2 | -------------------------------------------------------------------------------- /tests/test017.tig: -------------------------------------------------------------------------------- 1 | /* ERR: unknown type name */ 2 | t { hd = 42 } 3 | -------------------------------------------------------------------------------- /tests/test019.err: -------------------------------------------------------------------------------- 1 | error: test019.tig:4:8: repeated type name `t' 2 | -------------------------------------------------------------------------------- /test/good/print0.tig: -------------------------------------------------------------------------------- 1 | for i := 1 to 100 do (printi (i); print ("\n")) 2 | -------------------------------------------------------------------------------- /tests/test001.tig: -------------------------------------------------------------------------------- 1 | let var x := 12 var y := x + x in printi(y) end 2 | -------------------------------------------------------------------------------- /tests/test020.tig: -------------------------------------------------------------------------------- 1 | /* ERR: statement expected */ 2 | while 1 do 3 | 43 -------------------------------------------------------------------------------- /tests/test024.err: -------------------------------------------------------------------------------- 1 | error: test024.tig:3:12: `nil' cannot appear here 2 | -------------------------------------------------------------------------------- /tests/test026.err: -------------------------------------------------------------------------------- 1 | error: test026.tig:2:1: `break' cannot appear here 2 | -------------------------------------------------------------------------------- /tests/test030.err: -------------------------------------------------------------------------------- 1 | error: test030.tig:4:12: too many fields for type `t': b 2 | -------------------------------------------------------------------------------- /test/good/assign-nil.tig: -------------------------------------------------------------------------------- 1 | let type r = {a:int} var a := r{a=12} in a := nil end 2 | -------------------------------------------------------------------------------- /test/good/let-nil.tig: -------------------------------------------------------------------------------- 1 | let type r = {a : int} var a : r := nil in a.a end 2 | 3 | -------------------------------------------------------------------------------- /test/good/nested0.tig: -------------------------------------------------------------------------------- 1 | let var a := 101 function f () : int = a in f () end 2 | 3 | -------------------------------------------------------------------------------- /tests/test004.tig: -------------------------------------------------------------------------------- 1 | let 2 | var x := 0 3 | var y := 1 4 | in 5 | y := x 6 | end -------------------------------------------------------------------------------- /tests/test005.tig: -------------------------------------------------------------------------------- 1 | let 2 | var x := 42 3 | in 4 | if x > 12 then x := 0 5 | end -------------------------------------------------------------------------------- /test/good/lambdalift0.tig: -------------------------------------------------------------------------------- 1 | let var a := 13 function f () : int = a in f () end 2 | 3 | -------------------------------------------------------------------------------- /tests/test020.err: -------------------------------------------------------------------------------- 1 | error: test020.tig:3:3: this expression should not produce a value 2 | -------------------------------------------------------------------------------- /tests/test024.tig: -------------------------------------------------------------------------------- 1 | /* ERR: illegal nil */ 2 | let 3 | var x := nil 4 | in 5 | end 6 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | OVERVIEW: 2 | 3 | A compiler for the Tiger programming language targeting LLVM. 4 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.19) 2 | 3 | (package (name tigerc)) 4 | 5 | (using menhir 3.0) -------------------------------------------------------------------------------- /test/bad/rec0.tig: -------------------------------------------------------------------------------- 1 | let type rec0 = { a : int } type rec0 = {b : int} in a{a=1} end 2 | 3 | -------------------------------------------------------------------------------- /test/good/for0.tig: -------------------------------------------------------------------------------- 1 | let var a := 101 in for i := 0 to 99 do (if a then a := i) end 2 | 3 | -------------------------------------------------------------------------------- /tests/test002.tig: -------------------------------------------------------------------------------- 1 | let 2 | type t = int 3 | var x : t := 42 4 | in 5 | printi(x) 6 | end -------------------------------------------------------------------------------- /tests/test018.err: -------------------------------------------------------------------------------- 1 | error: test018.tig:2:1: wrong number of arguments: expected 1, got 2 2 | -------------------------------------------------------------------------------- /tests/test023.err: -------------------------------------------------------------------------------- 1 | error: test023.tig:6:12: record type `t' does not contain a field `r' 2 | -------------------------------------------------------------------------------- /tests/test027.err: -------------------------------------------------------------------------------- 1 | error: test027.tig:4:12: value-producing expression was expected here 2 | -------------------------------------------------------------------------------- /tests/test021.err: -------------------------------------------------------------------------------- 1 | error: test021.tig:5:10: this expression does not belong to a record type 2 | -------------------------------------------------------------------------------- /tests/test022.err: -------------------------------------------------------------------------------- 1 | error: test022.tig:5:10: this expression does not belong to an array type 2 | -------------------------------------------------------------------------------- /test/bad/rec1.tig: -------------------------------------------------------------------------------- 1 | let type arr = array of arr1 type arr1 = array of arr var a := 101 in a end 2 | 3 | -------------------------------------------------------------------------------- /test/good/for-escapes.tig: -------------------------------------------------------------------------------- 1 | for i := 1 to 100 do let function f () : int = i in printi (f()) end 2 | 3 | -------------------------------------------------------------------------------- /tests/test004.err: -------------------------------------------------------------------------------- 1 | 2 | define void @TIG_main() gc "shadow-stack" { 3 | entry: 4 | ret void 5 | } 6 | -------------------------------------------------------------------------------- /tests/test028.err: -------------------------------------------------------------------------------- 1 | error: test028.tig:4:12: some fields belonging to the type `t' are missing: b 2 | -------------------------------------------------------------------------------- /tests/test031.err: -------------------------------------------------------------------------------- 1 | error: test031.tig:4:12: some fields belonging to the type `t' are missing: a 2 | -------------------------------------------------------------------------------- /test/good/rec-nil.tig: -------------------------------------------------------------------------------- 1 | let type rec = {a : int, b : rec } var r := rec {a=12, b=nil} in r.b := nil end 2 | -------------------------------------------------------------------------------- /test/good/rec3.tig: -------------------------------------------------------------------------------- 1 | let type rec = {a : int, b : int } 2 | var x := rec { a=1, b=45 } in 3 | x.b 4 | end 5 | -------------------------------------------------------------------------------- /tests/test015.tig: -------------------------------------------------------------------------------- 1 | /* ERR: unknown variable */ 2 | let 3 | var x := 42 4 | in 5 | printi(y) 6 | end 7 | -------------------------------------------------------------------------------- /tests/test021.tig: -------------------------------------------------------------------------------- 1 | /* ERR: not a record */ 2 | let 3 | var x := 42 4 | in 5 | printi(x.r) 6 | end 7 | -------------------------------------------------------------------------------- /tests/test022.tig: -------------------------------------------------------------------------------- 1 | /* ERR: not an array */ 2 | let 3 | var x := 43 4 | in 5 | printi(x[18]) 6 | end 7 | -------------------------------------------------------------------------------- /tests/test029.err: -------------------------------------------------------------------------------- 1 | error: test029.tig:4:14: a field named `a' belonging to the type `t' was expected here 2 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all 2 | all: 3 | dune build 4 | 5 | .PHONY: test 6 | test: 7 | dune runtest --auto-promote -------------------------------------------------------------------------------- /test/good/nil-cmp.tig: -------------------------------------------------------------------------------- 1 | let type rec = {a:int} var r := rec{a=13} in if r = nil then r := rec{a=0} end 2 | 3 | -------------------------------------------------------------------------------- /test/good/rec0.tig: -------------------------------------------------------------------------------- 1 | let type rec = { a: int , b : int } 2 | var x := rec {a =1, b=34} in 3 | x 4 | end 5 | 6 | -------------------------------------------------------------------------------- /tests/test014.tig: -------------------------------------------------------------------------------- 1 | let 2 | var a := 34 3 | in 4 | while a do a := if a then (break; 1) else 3 5 | end 6 | 7 | -------------------------------------------------------------------------------- /tests/test019.tig: -------------------------------------------------------------------------------- 1 | /* ERR: repeated type name */ 2 | let 3 | type t = string 4 | type t = int 5 | in 6 | end -------------------------------------------------------------------------------- /tests/test027.tig: -------------------------------------------------------------------------------- 1 | /* ERR: value expected */ 2 | let 3 | var x := 42 4 | var y := (x := 0) 5 | in 6 | end 7 | -------------------------------------------------------------------------------- /tests/test031.tig: -------------------------------------------------------------------------------- 1 | /* ERR: missing fields */ 2 | let 3 | type t = {a:int} 4 | var x := t {} 5 | in 6 | end 7 | -------------------------------------------------------------------------------- /tests/test033.tig: -------------------------------------------------------------------------------- 1 | let 2 | type t = array of int 3 | var x := t [10] of 0 4 | in 5 | printi(x[10]) 6 | end -------------------------------------------------------------------------------- /test/good/nested1.tig: -------------------------------------------------------------------------------- 1 | let var a := 101 function f () = g () function g () = (a := 103; f ()) in 2 | f () 3 | end 4 | -------------------------------------------------------------------------------- /tests/test006.tig: -------------------------------------------------------------------------------- 1 | let 2 | type t = array of int 3 | var x := t [10] of 42 4 | in 5 | printi(x[3]) 6 | end 7 | -------------------------------------------------------------------------------- /test/good/mutually-recfns.tig: -------------------------------------------------------------------------------- 1 | let var a := 101 function f () : int = g () function g () : int = a in f () 2 | end 3 | 4 | -------------------------------------------------------------------------------- /test/good/rec1.tig: -------------------------------------------------------------------------------- 1 | let type rec = { a:int, b : rec } 2 | var a := rec { a = 123, b = nil } 3 | in 4 | a 5 | end 6 | 7 | -------------------------------------------------------------------------------- /tests/test029.tig: -------------------------------------------------------------------------------- 1 | /* ERR: unexpected field */ 2 | let 3 | type t = {a: int} 4 | var x := t{b = 42} 5 | in 6 | end 7 | -------------------------------------------------------------------------------- /test/good/fact.tig: -------------------------------------------------------------------------------- 1 | let function fact (n:int):int = 2 | if n=0 then 1 3 | else n*fact(n-1) 4 | in 5 | fact (10) 6 | end 7 | -------------------------------------------------------------------------------- /tests/test010.tig: -------------------------------------------------------------------------------- 1 | let 2 | type list = { hd: int, tl: list } 3 | var x : list := nil 4 | in 5 | printi(x.hd) 6 | end 7 | -------------------------------------------------------------------------------- /tests/test030.tig: -------------------------------------------------------------------------------- 1 | /* ERR: too many fields */ 2 | let 3 | type t = {a:int} 4 | var x := t {a=42, b=56} 5 | in 6 | end 7 | -------------------------------------------------------------------------------- /tests/test025.tig: -------------------------------------------------------------------------------- 1 | /* Valid nil */ 2 | let 3 | type t = { a : int } 4 | var x := t { a = 42 } 5 | in 6 | x := nil 7 | end 8 | -------------------------------------------------------------------------------- /tests/test023.tig: -------------------------------------------------------------------------------- 1 | /* ERR: unknown field */ 2 | let 3 | type t = {x: int} 4 | var x : t := nil 5 | in 6 | printi(x.r) 7 | end 8 | -------------------------------------------------------------------------------- /tests/test028.tig: -------------------------------------------------------------------------------- 1 | /* ERR: Wrong number of fields */ 2 | let 3 | type t = {a : int, b : string} 4 | var x := t{a = 42} 5 | in 6 | end 7 | -------------------------------------------------------------------------------- /tests/test032.tig: -------------------------------------------------------------------------------- 1 | let 2 | function fact (n: int) : int = 3 | if n then n * fact(n - 1) else 1 4 | in 5 | printi(fact(15)) 6 | end 7 | -------------------------------------------------------------------------------- /tests/test011.tig: -------------------------------------------------------------------------------- 1 | let 2 | type rec = { a : int, b : rec } 3 | type arr = array of rec 4 | var a := arr[10] of nil 5 | in 6 | a[3] := nil 7 | end 8 | -------------------------------------------------------------------------------- /tools/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name gen_tests) 3 | (modules gen_tests)) 4 | 5 | (executable 6 | (name run_test) 7 | (libraries unix) 8 | (modules run_test)) -------------------------------------------------------------------------------- /test/good/arr1.tig: -------------------------------------------------------------------------------- 1 | let type arr0 = array of int type arr1 = array of arr0 var a := arr1[10] of 2 | (arr0 [30] of 4) in 3 | a[1][(arr0 [10] of 34; 10)] 4 | end 5 | -------------------------------------------------------------------------------- /tests/test009.tig: -------------------------------------------------------------------------------- 1 | let 2 | type list = { hd: int, tl: list } 3 | var x := list { hd = 42, tl = list { hd = 12, tl = nil } } 4 | in 5 | printi(x.tl.hd) 6 | end 7 | -------------------------------------------------------------------------------- /src/typecheck.mli: -------------------------------------------------------------------------------- 1 | type error 2 | 3 | exception Error of error Tabs.loc 4 | 5 | val string_of_error: error -> string 6 | 7 | val program: Tabs.program -> Typing.program 8 | -------------------------------------------------------------------------------- /tests/test002.err: -------------------------------------------------------------------------------- 1 | 2 | define void @TIG_main() gc "shadow-stack" { 3 | entry: 4 | call void @TIG_printi(i64 42) 5 | ret void 6 | } 7 | 8 | declare void @TIG_printi(i64 %0) 9 | -------------------------------------------------------------------------------- /tests/test003.tig: -------------------------------------------------------------------------------- 1 | let 2 | var N := 100 3 | var x0 := 0 4 | var x1 := 1 5 | in 6 | for i := 1 to N do 7 | (let var x2 := x0 + x1 in x0 := x1; x1 := x2 end); 8 | printi(x1) 9 | end -------------------------------------------------------------------------------- /tests/test012.tig: -------------------------------------------------------------------------------- 1 | let 2 | type arr0 = array of int 3 | type arr1 = array of arr0 4 | var a := arr1[10] of (arr0[43] of 3) 5 | in 6 | a[3][5] := 123; 7 | printi(a[3][5]) 8 | end 9 | -------------------------------------------------------------------------------- /test/good/nested2.tig: -------------------------------------------------------------------------------- 1 | let var a := 101 var b := 102 2 | function f () = 3 | let var c := 103 4 | function g () = 5 | c := a + b 6 | in 7 | c := a 8 | end 9 | in 10 | b 11 | end 12 | 13 | -------------------------------------------------------------------------------- /test/good/rec-types.tig: -------------------------------------------------------------------------------- 1 | let type arr = arr1 2 | type arr1 = arr2 3 | type arr2 = array of rec 4 | type rec = {a:int, b : arr} 5 | var x := rec { a=1, b = arr[10] of nil} in 6 | x 7 | end 8 | 9 | -------------------------------------------------------------------------------- /tests/test001.err: -------------------------------------------------------------------------------- 1 | 2 | define void @TIG_main() gc "shadow-stack" { 3 | entry: 4 | %0 = add i64 12, 12 5 | call void @TIG_printi(i64 %0) 6 | ret void 7 | } 8 | 9 | declare void @TIG_printi(i64 %0) 10 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (include dune.inc) 2 | 3 | (rule 4 | (deps (glob_files *.tig)) 5 | (action (with-stdout-to dune.inc.gen (run ../tools/gen_tests.exe .)))) 6 | 7 | (rule 8 | (alias all) 9 | (action (diff dune.inc dune.inc.gen))) -------------------------------------------------------------------------------- /test/good/lambdalift1.tig: -------------------------------------------------------------------------------- 1 | let function fact (n:int): int = 2 | let function loop (acc:int, n:int):int = 3 | if n=0 then acc else loop(acc*n, n-1) 4 | in 5 | loop(1,n) 6 | end 7 | in 8 | printi(fact(10)) 9 | end 10 | 11 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (ocamllex lexer) 2 | 3 | (menhir (modules parser)) 4 | 5 | (executable 6 | (public_name tc) 7 | (name main) 8 | (libraries 9 | llvm 10 | llvm.target 11 | llvm.passbuilder 12 | llvm.bitwriter 13 | llvm.all_backends)) -------------------------------------------------------------------------------- /tests/test013.tig: -------------------------------------------------------------------------------- 1 | let 2 | var N := 50 3 | type arr = array of int 4 | var a := arr[N] of 0 5 | in 6 | for i := 0 to N-1 do 7 | a[i] := i; 8 | for i := 0 to N-1 do ( 9 | printi (a[i]); print ("\n") 10 | ) 11 | end 12 | -------------------------------------------------------------------------------- /tests/test008.err: -------------------------------------------------------------------------------- 1 | 2 | @0 = private unnamed_addr constant [15 x i8] c"Hello, World!\0A\00", align 1 3 | 4 | define void @TIG_main() gc "shadow-stack" { 5 | entry: 6 | call void @TIG_print(ptr @0) 7 | ret void 8 | } 9 | 10 | declare void @TIG_print(ptr %0) 11 | -------------------------------------------------------------------------------- /test/good/rec2.tig: -------------------------------------------------------------------------------- 1 | let type rec = { a : rec , b : int } 2 | var x := rec { a = rec { a = nil, b = 12 }, b = 34 } in 3 | printi (x.a.b); 4 | print("\n") 5 | end 6 | /* this tests the fact that x.a should be saved on the stack 7 | just in case the rest of the arguments (in this case, just x.b) 8 | were to call GC */ 9 | -------------------------------------------------------------------------------- /tests/test007.tig: -------------------------------------------------------------------------------- 1 | let 2 | type t = array of int 3 | var N := 500 4 | var x := t [N+1] of 1 5 | in 6 | print("PRIMES AT MOST "); printi(N); print("\n"); 7 | for i := 2 to N do ( 8 | if x[i] then ( 9 | printi(i); print(" "); 10 | for k := i to N/i do x[i*k] := 0 11 | ) 12 | ); 13 | print("\n") 14 | end -------------------------------------------------------------------------------- /tests/test007.out: -------------------------------------------------------------------------------- 1 | PRIMES AT MOST 500 2 | 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 163 167 173 179 181 191 193 197 199 211 223 227 229 233 239 241 251 257 263 269 271 277 281 283 293 307 311 313 317 331 337 347 349 353 359 367 373 379 383 389 397 401 409 419 421 431 433 439 443 449 457 461 463 467 479 487 491 499 3 | -------------------------------------------------------------------------------- /tests/test013.out: -------------------------------------------------------------------------------- 1 | 0 2 | 1 3 | 2 4 | 3 5 | 4 6 | 5 7 | 6 8 | 7 9 | 8 10 | 9 11 | 10 12 | 11 13 | 12 14 | 13 15 | 14 16 | 15 17 | 16 18 | 17 19 | 18 20 | 19 21 | 20 22 | 21 23 | 22 24 | 23 25 | 24 26 | 25 27 | 26 28 | 27 29 | 28 30 | 29 31 | 30 32 | 31 33 | 32 34 | 33 35 | 34 36 | 35 37 | 36 38 | 37 39 | 38 40 | 39 41 | 40 42 | 41 43 | 42 44 | 43 45 | 44 46 | 45 47 | 46 48 | 47 49 | 48 50 | 49 51 | -------------------------------------------------------------------------------- /tests/test005.err: -------------------------------------------------------------------------------- 1 | 2 | define void @TIG_main() gc "shadow-stack" { 3 | entry: 4 | %0 = icmp sgt i64 42, 12 5 | %1 = zext i1 %0 to i64 6 | %2 = icmp ne i64 %1, 0 7 | br i1 %2, label %3, label %5 8 | 9 | 3: ; preds = %entry 10 | br label %4 11 | 12 | 4: ; preds = %5, %3 13 | ret void 14 | 15 | 5: ; preds = %entry 16 | br label %4 17 | } 18 | -------------------------------------------------------------------------------- /tools/gen_tests.ml: -------------------------------------------------------------------------------- 1 | let output_stanza oc fn = 2 | let base = Filename.basename fn |> Filename.chop_extension in 3 | Printf.fprintf oc {| 4 | (rule 5 | (targets %s.out.gen %s.err.gen) 6 | (action (run ../tools/run_test.exe -cmd %%{dep:../src/main.exe} -runtime %%{dep:../runtime/runtime.c} -out %s.out.gen -err %s.err.gen %%{dep:%s.tig}))) 7 | 8 | (rule 9 | (alias runtest) 10 | (action (diff %s.out %s.out.gen))) 11 | 12 | (rule 13 | (alias runtest) 14 | (action (diff %s.err %s.err.gen))) 15 | |} base base base base base base base base base 16 | 17 | let () = 18 | Sys.readdir Filename.current_dir_name 19 | |> Array.to_list 20 | |> List.filter (String.ends_with ~suffix:".tig") 21 | |> List.iter (output_stanza stdout) 22 | -------------------------------------------------------------------------------- /tests/test032.err: -------------------------------------------------------------------------------- 1 | 2 | define void @TIG_main() gc "shadow-stack" { 3 | entry: 4 | %0 = call i64 @fact_1(i64 15) 5 | call void @TIG_printi(i64 %0) 6 | ret void 7 | } 8 | 9 | define i64 @fact_1(i64 %0) gc "shadow-stack" { 10 | entry: 11 | %1 = icmp ne i64 %0, 0 12 | br i1 %1, label %2, label %7 13 | 14 | 2: ; preds = %entry 15 | %3 = sub i64 %0, 1 16 | %4 = call i64 @fact_1(i64 %3) 17 | %5 = mul i64 %0, %4 18 | br label %6 19 | 20 | 6: ; preds = %7, %2 21 | %.0 = phi i64 [ %5, %2 ], [ 1, %7 ] 22 | ret i64 %.0 23 | 24 | 7: ; preds = %entry 25 | br label %6 26 | } 27 | 28 | declare void @TIG_printi(i64 %0) 29 | -------------------------------------------------------------------------------- /tests/test025.err: -------------------------------------------------------------------------------- 1 | 2 | define void @TIG_main() gc "shadow-stack" { 3 | entry: 4 | %0 = alloca ptr, align 8 5 | store ptr null, ptr %0, align 8 6 | call void @llvm.gcroot(ptr %0, ptr null) 7 | %1 = alloca ptr, align 8 8 | store ptr null, ptr %1, align 8 9 | call void @llvm.gcroot(ptr %1, ptr null) 10 | %2 = call ptr @TIG_makerecord(i32 1) 11 | %3 = getelementptr { i64 }, ptr %2, i64 0, i64 0 12 | store i64 42, ptr %3, align 4 13 | store ptr %2, ptr %0, align 8 14 | %4 = load ptr, ptr %0, align 8 15 | store ptr %4, ptr %1, align 8 16 | store ptr null, ptr %1, align 8 17 | ret void 18 | } 19 | 20 | ; Function Attrs: nounwind 21 | declare void @llvm.gcroot(ptr %0, ptr %1) #0 22 | 23 | declare ptr @TIG_makerecord(i32 %0) 24 | 25 | attributes #0 = { nounwind } 26 | -------------------------------------------------------------------------------- /test/good/queens.tig: -------------------------------------------------------------------------------- 1 | let 2 | var N := 8 3 | type intArray = array of int 4 | var row := intArray [ N ] of 0 5 | var col := intArray [ N ] of 0 6 | var diag1 := intArray [ N+N-1 ] of 0 7 | var diag2 := intArray [ N+N-1 ] of 0 8 | 9 | function printboard () = 10 | (for i := 0 to N-1 do 11 | (for j := 0 to N-1 do 12 | print (if col[i] = j then " O" else " ."); 13 | print ("\n")); 14 | print ("\n")) 15 | 16 | function try (c:int) = 17 | if c=N then printboard () 18 | else 19 | for r := 0 to N-1 do 20 | if row[r] = 0 & diag1[r+c] = 0 & 21 | diag2[r+7-c] = 0 then 22 | (row[r] := 1; 23 | diag1[r+c] := 1; 24 | diag2[r+7-c] := 1; 25 | col[c] := r; 26 | try (c+1); 27 | row[r] := 0; 28 | diag1[r+c] := 0; 29 | diag2[r+7-c] := 0) 30 | in try (0) end 31 | -------------------------------------------------------------------------------- /tests/test003.err: -------------------------------------------------------------------------------- 1 | 2 | define void @TIG_main() gc "shadow-stack" { 3 | entry: 4 | br label %0 5 | 6 | 0: ; preds = %entry, %9 7 | %.02 = phi i64 [ 1, %entry ], [ %7, %9 ] 8 | %.01 = phi i64 [ 0, %entry ], [ %.02, %9 ] 9 | %.0 = phi i64 [ 1, %entry ], [ %8, %9 ] 10 | %1 = icmp slt i64 100, %.0 11 | %2 = zext i1 %1 to i64 12 | %3 = icmp ne i64 %2, 0 13 | br i1 %3, label %4, label %6 14 | 15 | 4: ; preds = %0 16 | br label %5 17 | 18 | 5: ; preds = %4 19 | call void @TIG_printi(i64 %.02) 20 | ret void 21 | 22 | 6: ; preds = %0 23 | %7 = add i64 %.01, %.02 24 | %8 = add i64 %.0, 1 25 | br label %9 26 | 27 | 9: ; preds = %6 28 | br label %0 29 | } 30 | 31 | declare void @TIG_printi(i64 %0) 32 | -------------------------------------------------------------------------------- /tests/test014.err: -------------------------------------------------------------------------------- 1 | 2 | define void @TIG_main() gc "shadow-stack" { 3 | entry: 4 | br label %0 5 | 6 | 0: ; preds = %entry, %8 7 | %.0 = phi i64 [ 34, %entry ], [ 3, %8 ] 8 | %1 = icmp ne i64 %.0, 0 9 | br i1 %1, label %2, label %9 10 | 11 | 2: ; preds = %0 12 | %3 = icmp ne i64 %.0, 0 13 | br i1 %3, label %4, label %6 14 | 15 | 4: ; preds = %2 16 | br label %5 17 | 18 | 5: ; preds = %9, %4 19 | ret void 20 | 21 | 6: ; preds = %2 22 | br label %7 23 | 24 | 7: ; preds = %6 25 | br label %8 26 | 27 | 8: ; preds = %7 28 | br label %0 29 | 30 | 9: ; preds = %0 31 | br label %5 32 | } 33 | -------------------------------------------------------------------------------- /tests/test010.err: -------------------------------------------------------------------------------- 1 | 2 | @0 = private unnamed_addr constant [12 x i8] c"test010.tig\00", align 1 3 | 4 | define void @TIG_main() gc "shadow-stack" { 5 | entry: 6 | %0 = alloca ptr, align 8 7 | store ptr null, ptr %0, align 8 8 | call void @llvm.gcroot(ptr %0, ptr null) 9 | store ptr null, ptr %0, align 8 10 | %1 = load ptr, ptr %0, align 8 11 | %2 = icmp eq ptr %1, null 12 | br i1 %2, label %3, label %4 13 | 14 | 3: ; preds = %entry 15 | call void @TIG_nil_error(ptr @0, i64 5, i64 10) 16 | unreachable 17 | 18 | 4: ; preds = %entry 19 | %5 = getelementptr { i64, ptr }, ptr %1, i64 0, i64 0 20 | %6 = load i64, ptr %5, align 4 21 | call void @TIG_printi(i64 %6) 22 | ret void 23 | } 24 | 25 | ; Function Attrs: nounwind 26 | declare void @llvm.gcroot(ptr %0, ptr %1) #0 27 | 28 | declare void @TIG_nil_error(ptr %0, i64 %1, i64 %2) 29 | 30 | declare void @TIG_printi(i64 %0) 31 | 32 | attributes #0 = { nounwind } 33 | test010.tig:5:10: variable is nil 34 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | (* The MIT License (MIT) 2 | 3 | Copyright (c) 2013-2025 Nicolas Ojeda Bar 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 13 | all 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 | -------------------------------------------------------------------------------- /tools/run_test.ml: -------------------------------------------------------------------------------- 1 | let cmd = ref "" 2 | let runtime = ref "" 3 | let out_file = ref "" 4 | let err_file = ref "" 5 | 6 | let run fn = 7 | let base = Filename.basename fn |> Filename.chop_extension in 8 | let openfile fn = 9 | Unix.openfile fn [O_CREAT; O_WRONLY; O_TRUNC; O_SHARE_DELETE; O_CLOEXEC] 0o644 in 10 | let out_file = openfile !out_file in 11 | let err_file = openfile !err_file in 12 | let run_process cmd args = 13 | let pid = Unix.create_process cmd (Array.of_list (cmd :: args)) Unix.stdin out_file err_file in 14 | match Unix.waitpid [] pid with 15 | | _, WEXITED n -> n 16 | | _, (WSIGNALED n | WSTOPPED n) -> 128 + n 17 | in 18 | let code = run_process !cmd ["-dllvm"; fn] in 19 | if code = 0 then begin 20 | let exe_name = base ^ ".exe" in 21 | let code = run_process "cc" [base ^ ".o"; !runtime; "-o"; exe_name] in 22 | if code = 0 then ignore (run_process ("./" ^ exe_name) [exe_name]) 23 | end; 24 | Unix.close out_file; 25 | Unix.close err_file 26 | 27 | let () = 28 | let spec = 29 | [ "-cmd", Arg.Set_string cmd, " Command name"; 30 | "-runtime", Arg.Set_string runtime, " Runtime C file name"; 31 | "-out", Arg.Set_string out_file, " Output file"; 32 | "-err", Arg.Set_string err_file, " Error file" ] 33 | in 34 | Arg.parse (Arg.align spec) run "Test runner" 35 | -------------------------------------------------------------------------------- /src/tabs.ml: -------------------------------------------------------------------------------- 1 | type 'a loc = 2 | { 3 | desc: 'a; 4 | loc: Lexing.position; 5 | } 6 | 7 | type comparison = 8 | | Ceq | Cle | Cge | Cne | Clt | Cgt 9 | 10 | type bin = 11 | | Op_add | Op_sub | Op_mul | Op_div 12 | | Op_cmp of comparison 13 | 14 | type ident = 15 | string loc 16 | 17 | type typ = 18 | | Tname of ident 19 | | Tarray of ident 20 | | Trecord of (ident * ident) list 21 | 22 | type var = 23 | var_ loc 24 | 25 | and var_ = 26 | | Vsimple of ident 27 | | Vsubscript of var * exp 28 | | Vfield of var * ident 29 | 30 | and exp = 31 | exp_ loc 32 | 33 | and exp_ = 34 | | Eint of int64 35 | | Estring of string 36 | | Enil 37 | | Evar of var 38 | | Ebinop of exp * bin * exp 39 | | Eassign of var * exp 40 | | Ecall of ident * exp list 41 | | Eseq of exp list 42 | | Earray of ident * exp * exp 43 | | Erecord of ident * (ident * exp) list 44 | | Eif of exp * exp * exp option 45 | | Ewhile of exp * exp 46 | | Efor of ident * exp * exp * exp 47 | | Ebreak 48 | | Elet of dec list * exp 49 | 50 | and dec = 51 | | Dtype of ident * typ 52 | | Dfun of fundef 53 | | Dvar of ident * ident option * exp 54 | 55 | and fundef = 56 | { fn_name: ident; 57 | fn_rtyp: ident option; 58 | fn_args: (ident * ident) list; 59 | fn_body: exp } 60 | 61 | type program = 62 | { 63 | name: string; 64 | body: exp; 65 | } 66 | -------------------------------------------------------------------------------- /tests/test011.err: -------------------------------------------------------------------------------- 1 | 2 | @0 = private unnamed_addr constant [12 x i8] c"test011.tig\00", align 1 3 | 4 | define void @TIG_main() gc "shadow-stack" { 5 | entry: 6 | %0 = alloca ptr, align 8 7 | store ptr null, ptr %0, align 8 8 | call void @llvm.gcroot(ptr %0, ptr null) 9 | %1 = alloca ptr, align 8 10 | store ptr null, ptr %1, align 8 11 | call void @llvm.gcroot(ptr %1, ptr null) 12 | %2 = call ptr @TIG_makearray(i64 10, ptr null) 13 | store ptr %2, ptr %0, align 8 14 | %3 = load ptr, ptr %0, align 8 15 | store ptr %3, ptr %1, align 8 16 | %4 = load ptr, ptr %1, align 8 17 | %5 = getelementptr { i64, [0 x ptr] }, ptr %4, i64 0, i64 0 18 | %6 = load i64, ptr %5, align 4 19 | %7 = icmp slt i64 3, %6 20 | %8 = and i1 true, %7 21 | br i1 %8, label %9, label %11 22 | 23 | 9: ; preds = %entry 24 | %10 = getelementptr { i64, [0 x ptr] }, ptr %4, i64 0, i64 1, i64 3 25 | store ptr null, ptr %10, align 8 26 | ret void 27 | 28 | 11: ; preds = %entry 29 | call void @TIG_bounds_error(ptr @0, i64 6, i64 5) 30 | unreachable 31 | } 32 | 33 | ; Function Attrs: nounwind 34 | declare void @llvm.gcroot(ptr %0, ptr %1) #0 35 | 36 | declare ptr @TIG_makearray(i64 %0, i64 %1) 37 | 38 | declare void @TIG_bounds_error(ptr %0, i64 %1, i64 %2) 39 | 40 | attributes #0 = { nounwind } 41 | -------------------------------------------------------------------------------- /tests/test006.err: -------------------------------------------------------------------------------- 1 | 2 | @0 = private unnamed_addr constant [12 x i8] c"test006.tig\00", align 1 3 | 4 | define void @TIG_main() gc "shadow-stack" { 5 | entry: 6 | %0 = alloca ptr, align 8 7 | store ptr null, ptr %0, align 8 8 | call void @llvm.gcroot(ptr %0, ptr null) 9 | %1 = alloca ptr, align 8 10 | store ptr null, ptr %1, align 8 11 | call void @llvm.gcroot(ptr %1, ptr null) 12 | %2 = call ptr @TIG_makearray(i64 10, i64 42) 13 | store ptr %2, ptr %0, align 8 14 | %3 = load ptr, ptr %0, align 8 15 | store ptr %3, ptr %1, align 8 16 | %4 = load ptr, ptr %1, align 8 17 | %5 = getelementptr { i64, [0 x i64] }, ptr %4, i64 0, i64 0 18 | %6 = load i64, ptr %5, align 4 19 | %7 = icmp slt i64 3, %6 20 | %8 = and i1 true, %7 21 | br i1 %8, label %9, label %12 22 | 23 | 9: ; preds = %entry 24 | %10 = getelementptr { i64, [0 x i64] }, ptr %4, i64 0, i64 1, i64 3 25 | %11 = load i64, ptr %10, align 4 26 | call void @TIG_printi(i64 %11) 27 | ret void 28 | 29 | 12: ; preds = %entry 30 | call void @TIG_bounds_error(ptr @0, i64 5, i64 12) 31 | unreachable 32 | } 33 | 34 | ; Function Attrs: nounwind 35 | declare void @llvm.gcroot(ptr %0, ptr %1) #0 36 | 37 | declare ptr @TIG_makearray(i64 %0, i64 %1) 38 | 39 | declare void @TIG_printi(i64 %0) 40 | 41 | declare void @TIG_bounds_error(ptr %0, i64 %1, i64 %2) 42 | 43 | attributes #0 = { nounwind } 44 | -------------------------------------------------------------------------------- /tests/test033.err: -------------------------------------------------------------------------------- 1 | 2 | @0 = private unnamed_addr constant [12 x i8] c"test033.tig\00", align 1 3 | 4 | define void @TIG_main() gc "shadow-stack" { 5 | entry: 6 | %0 = alloca ptr, align 8 7 | store ptr null, ptr %0, align 8 8 | call void @llvm.gcroot(ptr %0, ptr null) 9 | %1 = alloca ptr, align 8 10 | store ptr null, ptr %1, align 8 11 | call void @llvm.gcroot(ptr %1, ptr null) 12 | %2 = call ptr @TIG_makearray(i64 10, i64 0) 13 | store ptr %2, ptr %0, align 8 14 | %3 = load ptr, ptr %0, align 8 15 | store ptr %3, ptr %1, align 8 16 | %4 = load ptr, ptr %1, align 8 17 | %5 = getelementptr { i64, [0 x i64] }, ptr %4, i64 0, i64 0 18 | %6 = load i64, ptr %5, align 4 19 | %7 = icmp slt i64 10, %6 20 | %8 = and i1 true, %7 21 | br i1 %8, label %9, label %12 22 | 23 | 9: ; preds = %entry 24 | %10 = getelementptr { i64, [0 x i64] }, ptr %4, i64 0, i64 1, i64 10 25 | %11 = load i64, ptr %10, align 4 26 | call void @TIG_printi(i64 %11) 27 | ret void 28 | 29 | 12: ; preds = %entry 30 | call void @TIG_bounds_error(ptr @0, i64 5, i64 12) 31 | unreachable 32 | } 33 | 34 | ; Function Attrs: nounwind 35 | declare void @llvm.gcroot(ptr %0, ptr %1) #0 36 | 37 | declare ptr @TIG_makearray(i64 %0, i64 %1) 38 | 39 | declare void @TIG_printi(i64 %0) 40 | 41 | declare void @TIG_bounds_error(ptr %0, i64 %1, i64 %2) 42 | 43 | attributes #0 = { nounwind } 44 | test033.tig:5:12: out of bounds 45 | -------------------------------------------------------------------------------- /src/irep.mli: -------------------------------------------------------------------------------- 1 | type ty = 2 | | Tvoid 3 | | Tstruct of ty list 4 | | Tarray of ty * int 5 | | Tnamed of string 6 | | Tpointer 7 | | Tint of int 8 | 9 | type signature = ty list * ty 10 | 11 | type operation = 12 | | Pconstint of int64 13 | | Pconststring of string 14 | | Pnull 15 | | Pparam of int 16 | | Paddint 17 | | Psubint 18 | | Pmulint 19 | | Pdivint 20 | | Pgep of ty 21 | | Pcmpint of Tabs.comparison 22 | | Pand 23 | | Pzext 24 | | Ialloca of ty * bool (* gcroot *) 25 | | Iexternal of string * signature 26 | | Icall of Typing.ident 27 | | Imakearray 28 | | Imakerecord of int 29 | 30 | module Reg: sig 31 | type t 32 | type state 33 | val create: unit -> state 34 | val next: state -> t 35 | module Map: Map.S with type key = t 36 | end 37 | 38 | module Label: sig 39 | type t 40 | type state 41 | val create: unit -> state 42 | val next: state -> t 43 | module Map: Map.S with type key = t 44 | module Tbl: Hashtbl.S with type key = t 45 | end 46 | 47 | type reg = Reg.t 48 | type label = Label.t 49 | 50 | type instruction = 51 | | Iop of operation * reg list * reg * instruction 52 | | Iload of ty * reg * reg * instruction 53 | | Istore of reg * reg * instruction 54 | | Iifthenelse of reg * label * label 55 | | Igoto of label 56 | | Ireturn of reg option 57 | | Iunreachable 58 | 59 | type fundef = 60 | { 61 | name: Typing.fundef_name; 62 | signature: signature; 63 | code: instruction Label.Map.t; 64 | entrypoint: instruction; 65 | } 66 | 67 | type program = 68 | { 69 | funs: fundef list; 70 | } 71 | 72 | val transl_program: program -> Llvm.llmodule 73 | -------------------------------------------------------------------------------- /test/good/gc0.tig: -------------------------------------------------------------------------------- 1 | let 2 | type node = {key:int, left:node, right: node} 3 | type any = {any:int} 4 | 5 | var buffer := getchar () 6 | 7 | function add (n:int, tree:node) : node = 8 | if tree = nil then 9 | node{key=n, left=nil, right=nil} 10 | else if n = tree.key then 11 | tree 12 | else if n < tree.key then 13 | node{key=tree.key, left=add(n, tree.left), right=tree.right} 14 | else 15 | node{key=tree.key, left=tree.left, right=add (n, tree.right)} 16 | 17 | function print_tree (tree : node) = 18 | if tree <> nil then 19 | (/* 20 | print("print_tree: not nil, key = "); printi (tree.key); print("\n"); 21 | */ 22 | print_tree (tree.left); 23 | printi(tree.key); 24 | print(" "); 25 | print_tree (tree.right)) 26 | 27 | function readint (any: any) : int = 28 | let 29 | var i := 0 30 | function isdigit (s: string) : int = 31 | ord(buffer) >= ord("0") & ord(buffer) <= ord("9") 32 | in 33 | while buffer=" " | buffer = "\n" do 34 | buffer := getchar(); 35 | any.any := isdigit(buffer); 36 | while isdigit(buffer) do 37 | (i := i*10+ord(buffer)-ord("0"); 38 | buffer := getchar()); 39 | i 40 | end 41 | 42 | function readlist (tree : node) : node = 43 | let 44 | var any := any{any=0} 45 | var i := readint (any) 46 | in 47 | if any.any then 48 | (/* print ("adding "); printi(i); print(" to list\n"); */ 49 | readlist (add (i, tree))) 50 | else 51 | (/* print("done reading\n"); */ 52 | tree) 53 | end 54 | in 55 | let 56 | var tree := readlist(nil) 57 | in 58 | gc_collect (); 59 | print_tree (tree); 60 | print ("\n") 61 | end 62 | end 63 | -------------------------------------------------------------------------------- /runtime/tiger_stdlib.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | void* llvm_gc_allocate(unsigned); 6 | void llvm_gc_collect(void); 7 | 8 | void __tiger__print (char* s) 9 | { 10 | printf ("%s", s); 11 | } 12 | 13 | void __tiger__printi (int i) 14 | { 15 | printf ("%d", i); 16 | } 17 | 18 | void __tiger__flush () 19 | { 20 | fflush (stdout); 21 | } 22 | 23 | char* __tiger__getchar (void) 24 | { 25 | char* s; 26 | char c = getchar (); 27 | if (c == EOF) { 28 | s = llvm_gc_allocate(1); 29 | s[0] = '\0'; 30 | return s; 31 | } 32 | 33 | s = llvm_gc_allocate(2); 34 | s[0] = c; 35 | s[1] = '\0'; 36 | 37 | return s; 38 | } 39 | 40 | int __tiger__ord (char* s) 41 | { 42 | return s[0] == '\0' ? -1 : (int) s[0]; 43 | } 44 | 45 | char* __tiger__chr (int i) 46 | { 47 | char* s; 48 | 49 | if (i < 0 || i >= 256) { 50 | fprintf (stderr, "chr: out of range\n"); 51 | exit (2); 52 | } 53 | s = llvm_gc_allocate (2); 54 | 55 | s[0] = (char) i; 56 | s[1] = '\0'; 57 | 58 | return s; 59 | } 60 | 61 | int __tiger__size (char* s) 62 | { 63 | return strlen (s); 64 | } 65 | 66 | char* __tiger__substring (char* s, int off, int len) 67 | { 68 | char* s1 = llvm_gc_allocate (len+1); 69 | strncpy (s1, &s[off], len+1); 70 | return s1; 71 | } 72 | 73 | char* __tiger__concat (char* s1, char* s2) 74 | { 75 | char* s = llvm_gc_allocate (strlen (s1) + strlen (s2) + 1); /* this should be replaced by GC_allocator */ 76 | 77 | strcpy (s, s1); 78 | strcpy (&s[strlen(s1)], s2); 79 | 80 | return s; 81 | } 82 | 83 | int __tiger__not (int i) 84 | { 85 | if (i) { return 0; }; 86 | 87 | return 1; 88 | } 89 | 90 | void __tiger__exit (int i) 91 | { 92 | exit (i); 93 | } 94 | 95 | void __tiger__gc_collect (void) 96 | { 97 | llvm_gc_collect (); 98 | } 99 | -------------------------------------------------------------------------------- /src/fmt.ml: -------------------------------------------------------------------------------- 1 | open Format 2 | open Tabs 3 | 4 | let string_of_binary_operation = function 5 | | Op_add -> "+" 6 | | _ -> "" 7 | 8 | let rec declaration ppf d = 9 | match d with 10 | | Dvar (s, _, e) -> 11 | fprintf ppf "@[<2>var %s := %a@]" s.desc expression e 12 | | _ -> 13 | assert false 14 | 15 | and variable ppf v = 16 | match v.desc with 17 | | Vsimple s -> pp_print_string ppf s.desc 18 | | _ -> assert false 19 | 20 | and expression ppf e = 21 | match e.desc with 22 | | Eint n -> pp_print_string ppf (Int64.to_string n) 23 | | Estring s -> fprintf ppf "%S" s 24 | | Enil -> pp_print_string ppf "nil" 25 | | Evar v -> variable ppf v 26 | | Ebinop (e1, op, e2) -> 27 | fprintf ppf "@[<2>%a %s@ %a@]" expression e1 (string_of_binary_operation op) expression e2 28 | | Eassign (v, e) -> 29 | fprintf ppf "@[<2>%a := %a@]" variable v expression e 30 | | Ecall (s, el) -> 31 | let arguments = pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ") expression in 32 | fprintf ppf "@[%s(%a)@]" s.desc arguments el 33 | | Eseq el -> 34 | fprintf ppf "@[(%a)@]" (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ";@ ") expression) el 35 | | Earray (ty, e1, e2) -> 36 | fprintf ppf "@[<2>%s[%a] of@ %a@]" ty.desc expression e1 expression e2 37 | | Erecord _ -> 38 | assert false 39 | | Eif (e1, e2, None) -> 40 | fprintf ppf "@[if@ %a@ then@ %a]" expression e1 expression e2 41 | | Eif (e1, e2, Some e3) -> 42 | fprintf ppf "@[if@ %a@ then@ %a@ else@ %a@]" expression e1 expression e2 expression e3 43 | | Ewhile (e1, e2) -> 44 | fprintf ppf "@[while@ %a@ do@ %a@]" expression e1 expression e2 45 | | Efor _ -> 46 | assert false 47 | | Ebreak -> 48 | pp_print_string ppf "break" 49 | | Elet (ds, e) -> 50 | let declarations = pp_print_list ~pp_sep:pp_print_cut declaration in 51 | fprintf ppf "@[let @[%a@] in@ %a@ end@]" declarations ds expression e 52 | -------------------------------------------------------------------------------- /tests/test009.err: -------------------------------------------------------------------------------- 1 | 2 | @0 = private unnamed_addr constant [12 x i8] c"test009.tig\00", align 1 3 | 4 | define void @TIG_main() gc "shadow-stack" { 5 | entry: 6 | %0 = alloca ptr, align 8 7 | store ptr null, ptr %0, align 8 8 | call void @llvm.gcroot(ptr %0, ptr null) 9 | %1 = alloca ptr, align 8 10 | store ptr null, ptr %1, align 8 11 | call void @llvm.gcroot(ptr %1, ptr null) 12 | %2 = alloca ptr, align 8 13 | store ptr null, ptr %2, align 8 14 | call void @llvm.gcroot(ptr %2, ptr null) 15 | %3 = call ptr @TIG_makerecord(i32 2) 16 | %4 = getelementptr { i64, ptr }, ptr %3, i64 0, i64 0 17 | store i64 12, ptr %4, align 4 18 | %5 = getelementptr { i64, ptr }, ptr %3, i64 0, i64 1 19 | store ptr null, ptr %5, align 8 20 | store ptr %3, ptr %0, align 8 21 | %6 = call ptr @TIG_makerecord(i32 2) 22 | %7 = load ptr, ptr %0, align 8 23 | %8 = getelementptr { i64, ptr }, ptr %6, i64 0, i64 0 24 | store i64 42, ptr %8, align 4 25 | %9 = getelementptr { i64, ptr }, ptr %6, i64 0, i64 1 26 | store ptr %7, ptr %9, align 8 27 | store ptr %6, ptr %1, align 8 28 | %10 = load ptr, ptr %1, align 8 29 | store ptr %10, ptr %2, align 8 30 | %11 = load ptr, ptr %2, align 8 31 | %12 = icmp eq ptr %11, null 32 | br i1 %12, label %13, label %14 33 | 34 | 13: ; preds = %entry 35 | call void @TIG_nil_error(ptr @0, i64 5, i64 10) 36 | unreachable 37 | 38 | 14: ; preds = %entry 39 | %15 = getelementptr { i64, ptr }, ptr %11, i64 0, i64 1 40 | %16 = load ptr, ptr %15, align 8 41 | %17 = icmp eq ptr %16, null 42 | br i1 %17, label %18, label %19 43 | 44 | 18: ; preds = %14 45 | call void @TIG_nil_error(ptr @0, i64 5, i64 10) 46 | unreachable 47 | 48 | 19: ; preds = %14 49 | %20 = getelementptr { i64, ptr }, ptr %16, i64 0, i64 0 50 | %21 = load i64, ptr %20, align 4 51 | call void @TIG_printi(i64 %21) 52 | ret void 53 | } 54 | 55 | ; Function Attrs: nounwind 56 | declare void @llvm.gcroot(ptr %0, ptr %1) #0 57 | 58 | declare ptr @TIG_makerecord(i32 %0) 59 | 60 | declare void @TIG_nil_error(ptr %0, i64 %1, i64 %2) 61 | 62 | declare void @TIG_printi(i64 %0) 63 | 64 | attributes #0 = { nounwind } 65 | -------------------------------------------------------------------------------- /runtime/runtime.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | struct FrameMap { 6 | int32_t NumRoots; 7 | int32_t NumMeta; 8 | const void *Meta[0]; 9 | }; 10 | 11 | struct StackEntry { 12 | struct StackEntry *Next; 13 | const struct FrameMap *Map; 14 | void *Roots[0]; 15 | }; 16 | 17 | extern struct StackEntry *llvm_gc_root_chain; 18 | 19 | static void VisitGCRoots(void (*Visitor)(void **Root, const void *Meta, void *data), void *data) 20 | { 21 | for (struct StackEntry *R = llvm_gc_root_chain; R; R = R->Next) { 22 | unsigned i = 0; 23 | 24 | // For roots [0, NumMeta), the metadata pointer is in the FrameMap. 25 | for (unsigned e = R->Map->NumMeta; i != e; ++i) 26 | Visitor(&R->Roots[i], R->Map->Meta[i], data); 27 | 28 | // For roots [NumMeta, NumRoots), the metadata pointer is null. 29 | for (unsigned e = R->Map->NumRoots; i != e; ++i) 30 | Visitor(&R->Roots[i], NULL, data); 31 | } 32 | } 33 | 34 | static void incr(void **Root, const void *Meta, void *count) 35 | { 36 | int *c = (int *)count; 37 | ++*c; 38 | } 39 | 40 | static int CountGCRoots(void) 41 | { 42 | int count = 0; 43 | VisitGCRoots(incr, &count); 44 | return count; 45 | } 46 | 47 | void TIG_printi(int n) 48 | { 49 | printf("%d", n); 50 | fflush(stdout); 51 | } 52 | 53 | void TIG_print(char *s) 54 | { 55 | fputs(s, stdout); 56 | } 57 | 58 | void TIG_flush(void) 59 | { 60 | fflush(stdout); 61 | } 62 | 63 | intptr_t TIG_not(intptr_t x) 64 | { 65 | return (x == 0) ? 1 : 0; 66 | } 67 | 68 | void TIG_exit(intptr_t n) 69 | { 70 | exit(n); 71 | } 72 | 73 | intptr_t* TIG_makearray(ssize_t n, intptr_t x) 74 | { 75 | intptr_t *arr = calloc(n+1, sizeof(intptr_t)); 76 | arr[0] = n; 77 | for (int i = 1; i <= n; i ++) { 78 | arr[i] = x; 79 | } 80 | return arr; 81 | } 82 | 83 | intptr_t* TIG_makerecord(ssize_t n) 84 | { 85 | printf("# GC roots: %d\n", CountGCRoots()); fflush(stdout); 86 | return calloc(n, sizeof(intptr_t)); 87 | } 88 | 89 | void TIG_nil_error(char *filename, intptr_t lineno, intptr_t column) 90 | { 91 | fprintf(stderr, "%s:%ld:%ld: variable is nil\n", filename, lineno, column); 92 | fflush(stderr); 93 | exit(2); 94 | } 95 | 96 | void TIG_bounds_error(char *filename, intptr_t lineno, intptr_t column) 97 | { 98 | fprintf(stderr, "%s:%ld:%ld: out of bounds\n", filename, lineno, column); 99 | fflush(stderr); 100 | exit(2); 101 | } 102 | 103 | extern void TIG_main(void); 104 | 105 | int main(int argc, char **argv) 106 | { 107 | TIG_main(); 108 | return 0; 109 | } -------------------------------------------------------------------------------- /src/typing.ml: -------------------------------------------------------------------------------- 1 | module Ident: sig 2 | type t 3 | type state 4 | val new_state: unit -> state 5 | val create: state -> string -> t 6 | val name: t -> string 7 | val unique_name: t -> string 8 | val equal: t -> t -> bool 9 | module Set: Set.S with type elt = t 10 | module Map: Map.S with type key = t 11 | end = struct 12 | type t = { name: string; id: int } 13 | type state = int ref 14 | let new_state () = ref 0 15 | let create r name = incr r; { name; id = !r } 16 | let name { name; id = _ } = name 17 | let unique_name { name; id } = Printf.sprintf "%s_%i" name id 18 | let compare t1 t2 = Int.compare t1.id t2.id 19 | let equal t1 t2 = Int.equal t1.id t2.id 20 | module Set = Set.Make(struct type nonrec t = t let compare = compare end) 21 | module Map = Map.Make(struct type nonrec t = t let compare = compare end) 22 | end 23 | 24 | type ident = Ident.t 25 | 26 | type type_structure = 27 | | Tarray of type_id 28 | | Trecord of (string * type_id) list 29 | 30 | and type_id = 31 | | Tint 32 | | Tstring 33 | | Tconstr of ident 34 | 35 | type signature = 36 | type_id list * type_id option 37 | 38 | type loc = 39 | { 40 | filename: string; 41 | lineno: int; 42 | column: int; 43 | } 44 | 45 | type implem = 46 | | External of string 47 | | Internal of ident 48 | 49 | type 'a typed = 50 | { 51 | desc: 'a; 52 | ty: type_id; 53 | } 54 | 55 | type variable' = 56 | | Vsimple of ident 57 | | Vsubscript of loc * variable * expression 58 | | Vfield of loc * variable * int 59 | 60 | and variable = 61 | variable' typed 62 | 63 | and expression' = 64 | | Eint of int64 65 | | Estring of string 66 | | Enil 67 | | Evar of variable 68 | | Ebinop of expression * Tabs.bin * expression 69 | 70 | and expression = 71 | expression' typed 72 | 73 | and statement = 74 | | Sskip 75 | | Sloop of statement 76 | | Sbreak 77 | | Sifthenelse of expression * statement * statement 78 | | Sseq of statement * statement 79 | | Sassign of variable * expression 80 | | Scall of variable option * implem * expression list * signature 81 | | Sreturn of expression option 82 | | Sarray of variable * expression * expression 83 | | Srecord of variable * expression list 84 | 85 | type fundef_name = 86 | | Main 87 | | Internal of ident 88 | 89 | type fundef = 90 | { fn_name: fundef_name; 91 | fn_rtyp: type_id option; 92 | fn_args: (ident * type_id) list; 93 | fn_vars: (ident * type_id) list; 94 | fn_esca: Ident.Set.t; 95 | fn_body: statement } 96 | 97 | type program = 98 | { 99 | cstr: (ident * type_structure) list; 100 | funs: fundef list; 101 | } 102 | -------------------------------------------------------------------------------- /tests/test012.err: -------------------------------------------------------------------------------- 1 | 2 | @0 = private unnamed_addr constant [12 x i8] c"test012.tig\00", align 1 3 | 4 | define void @TIG_main() gc "shadow-stack" { 5 | entry: 6 | %0 = alloca ptr, align 8 7 | store ptr null, ptr %0, align 8 8 | call void @llvm.gcroot(ptr %0, ptr null) 9 | %1 = alloca ptr, align 8 10 | store ptr null, ptr %1, align 8 11 | call void @llvm.gcroot(ptr %1, ptr null) 12 | %2 = alloca ptr, align 8 13 | store ptr null, ptr %2, align 8 14 | call void @llvm.gcroot(ptr %2, ptr null) 15 | %3 = call ptr @TIG_makearray(i64 43, i64 3) 16 | store ptr %3, ptr %0, align 8 17 | %4 = load ptr, ptr %0, align 8 18 | %5 = call ptr @TIG_makearray(i64 10, ptr %4) 19 | store ptr %5, ptr %1, align 8 20 | %6 = load ptr, ptr %1, align 8 21 | store ptr %6, ptr %2, align 8 22 | %7 = load ptr, ptr %2, align 8 23 | %8 = getelementptr { i64, [0 x ptr] }, ptr %7, i64 0, i64 0 24 | %9 = load i64, ptr %8, align 4 25 | %10 = icmp slt i64 3, %9 26 | %11 = and i1 true, %10 27 | br i1 %11, label %12, label %39 28 | 29 | 12: ; preds = %entry 30 | %13 = getelementptr { i64, [0 x ptr] }, ptr %7, i64 0, i64 1, i64 3 31 | %14 = load ptr, ptr %13, align 8 32 | %15 = getelementptr { i64, [0 x i64] }, ptr %14, i64 0, i64 0 33 | %16 = load i64, ptr %15, align 4 34 | %17 = icmp slt i64 5, %16 35 | %18 = and i1 true, %17 36 | br i1 %18, label %19, label %38 37 | 38 | 19: ; preds = %12 39 | %20 = getelementptr { i64, [0 x i64] }, ptr %14, i64 0, i64 1, i64 5 40 | store i64 123, ptr %20, align 4 41 | %21 = load ptr, ptr %2, align 8 42 | %22 = getelementptr { i64, [0 x ptr] }, ptr %21, i64 0, i64 0 43 | %23 = load i64, ptr %22, align 4 44 | %24 = icmp slt i64 3, %23 45 | %25 = and i1 true, %24 46 | br i1 %25, label %26, label %37 47 | 48 | 26: ; preds = %19 49 | %27 = getelementptr { i64, [0 x ptr] }, ptr %21, i64 0, i64 1, i64 3 50 | %28 = load ptr, ptr %27, align 8 51 | %29 = getelementptr { i64, [0 x i64] }, ptr %28, i64 0, i64 0 52 | %30 = load i64, ptr %29, align 4 53 | %31 = icmp slt i64 5, %30 54 | %32 = and i1 true, %31 55 | br i1 %32, label %33, label %36 56 | 57 | 33: ; preds = %26 58 | %34 = getelementptr { i64, [0 x i64] }, ptr %28, i64 0, i64 1, i64 5 59 | %35 = load i64, ptr %34, align 4 60 | call void @TIG_printi(i64 %35) 61 | ret void 62 | 63 | 36: ; preds = %26 64 | call void @TIG_bounds_error(ptr @0, i64 7, i64 15) 65 | unreachable 66 | 67 | 37: ; preds = %19 68 | call void @TIG_bounds_error(ptr @0, i64 7, i64 12) 69 | unreachable 70 | 71 | 38: ; preds = %12 72 | call void @TIG_bounds_error(ptr @0, i64 6, i64 8) 73 | unreachable 74 | 75 | 39: ; preds = %entry 76 | call void @TIG_bounds_error(ptr @0, i64 6, i64 5) 77 | unreachable 78 | } 79 | 80 | ; Function Attrs: nounwind 81 | declare void @llvm.gcroot(ptr %0, ptr %1) #0 82 | 83 | declare ptr @TIG_makearray(i64 %0, i64 %1) 84 | 85 | declare void @TIG_printi(i64 %0) 86 | 87 | declare void @TIG_bounds_error(ptr %0, i64 %1, i64 %2) 88 | 89 | attributes #0 = { nounwind } 90 | -------------------------------------------------------------------------------- /src/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Parser 3 | 4 | exception Error of Lexing.position * string 5 | 6 | let str_buf = Buffer.create 20;; 7 | let keywords = Hashtbl.create 10;; 8 | 9 | List.iter (fun (x, y) -> Hashtbl.add keywords x y) 10 | [ "if", IF; 11 | "then", THEN; 12 | "else", ELSE; 13 | "var", VAR; 14 | "end", END; 15 | "let", LET; 16 | "for", FOR; 17 | "while", WHILE; 18 | "do", DO; 19 | "to", TO; 20 | "in", IN; 21 | "nil", NIL; 22 | "break", BREAK; 23 | "array", ARRAY; 24 | "of", OF; 25 | "function", FUNCTION; 26 | "type", TYPE ] 27 | } 28 | 29 | rule token = parse 30 | | '\n' 31 | { Lexing.new_line lexbuf; 32 | token lexbuf } 33 | | ['A'-'Z''a'-'z''_']['a'-'z''A'-'Z''0'-'9''_']* as id 34 | { try Hashtbl.find keywords id with Not_found -> IDENT id } 35 | | ['0'-'9']+ as int 36 | { INT (Int64.of_string int) } 37 | | '+' 38 | { PLUS } 39 | | '*' 40 | { TIMES } 41 | | '-' 42 | { MINUS } 43 | | '/' 44 | { SLASH } 45 | | '&' 46 | { LAND } 47 | | '|' 48 | { LOR } 49 | | ":=" 50 | { COLONEQ } 51 | | ':' 52 | { COLON } 53 | | ',' 54 | { COMMA } 55 | | '=' 56 | { EQ } 57 | | "<>" 58 | { NE } 59 | | "<=" 60 | { LE } 61 | | '<' 62 | { LT } 63 | | ">=" 64 | { GE } 65 | | '>' 66 | { GT } 67 | | '.' 68 | { DOT } 69 | | ';' 70 | { SEMI } 71 | | '{' 72 | { LCURLY } 73 | | '}' 74 | { RCURLY } 75 | | '[' 76 | { LBRACK } 77 | | ']' 78 | { RBRACK } 79 | | '(' 80 | { LPAREN } 81 | | ')' 82 | { RPAREN } 83 | | [' ' '\t']+ 84 | { token lexbuf } 85 | | "/*" 86 | { comment 0 lexbuf } 87 | | '"' 88 | { string lexbuf } 89 | | eof 90 | { EOF } 91 | | _ 92 | { raise (Error (lexbuf.Lexing.lex_curr_p, "lexer error")) } 93 | 94 | and string = parse 95 | | '"' 96 | { let s = Buffer.contents str_buf in 97 | Buffer.clear str_buf; 98 | STRING s } 99 | | '\n' 100 | { Lexing.new_line lexbuf; 101 | Buffer.add_char str_buf '\n'; 102 | string lexbuf } 103 | | "\\n" 104 | { Buffer.add_char str_buf '\n'; 105 | string lexbuf } 106 | | "\\t" 107 | { Buffer.add_char str_buf '\t'; 108 | string lexbuf } 109 | | "\\\"" 110 | { Buffer.add_char str_buf '"'; 111 | string lexbuf } 112 | | "\\" ((['0'-'9']['0'-'9']['0'-'9']) as lxm) 113 | { Buffer.add_char str_buf (char_of_int (int_of_string lxm)); 114 | string lexbuf } 115 | | "\\\\" 116 | { Buffer.add_char str_buf '\\'; 117 | string lexbuf } 118 | | '\\' [' ' '\t'] 119 | { skip_whitespace lexbuf } 120 | (* | '\\' '\n' 121 | { Lexing.new_line lexbuf; (* incr_linenum lexbuf; *) 122 | skip_whitespace lexbuf } *) 123 | | eof 124 | { EOF } 125 | | _ as c 126 | { Buffer.add_char str_buf c; 127 | string lexbuf } 128 | 129 | and skip_whitespace = parse 130 | | '\\' 131 | { string lexbuf } 132 | | '\n' 133 | { Lexing.new_line lexbuf; 134 | skip_whitespace lexbuf } 135 | | [' ' '\t']+ 136 | { skip_whitespace lexbuf } 137 | | eof 138 | { EOF } 139 | 140 | and comment lvl = parse 141 | | "*/" { if lvl = 0 then token lexbuf else comment (lvl-1) lexbuf } 142 | | "/*" { comment (lvl+1) lexbuf } 143 | | _ { comment lvl lexbuf } 144 | | eof 145 | { EOF } 146 | -------------------------------------------------------------------------------- /tests/test013.err: -------------------------------------------------------------------------------- 1 | 2 | @0 = private unnamed_addr constant [2 x i8] c"\0A\00", align 1 3 | @1 = private unnamed_addr constant [12 x i8] c"test013.tig\00", align 1 4 | 5 | define void @TIG_main() gc "shadow-stack" { 6 | entry: 7 | %0 = alloca ptr, align 8 8 | store ptr null, ptr %0, align 8 9 | call void @llvm.gcroot(ptr %0, ptr null) 10 | %1 = alloca ptr, align 8 11 | store ptr null, ptr %1, align 8 12 | call void @llvm.gcroot(ptr %1, ptr null) 13 | %2 = call ptr @TIG_makearray(i64 50, i64 0) 14 | store ptr %2, ptr %0, align 8 15 | %3 = load ptr, ptr %0, align 8 16 | store ptr %3, ptr %1, align 8 17 | br label %4 18 | 19 | 4: ; preds = %entry, %41 20 | %.01 = phi i64 [ 0, %entry ], [ %40, %41 ] 21 | %5 = sub i64 50, 1 22 | %6 = icmp slt i64 %5, %.01 23 | %7 = zext i1 %6 to i64 24 | %8 = icmp ne i64 %7, 0 25 | br i1 %8, label %9, label %31 26 | 27 | 9: ; preds = %4 28 | br label %10 29 | 30 | 10: ; preds = %9 31 | br label %11 32 | 33 | 11: ; preds = %10, %29 34 | %.0 = phi i64 [ 0, %10 ], [ %28, %29 ] 35 | %12 = sub i64 50, 1 36 | %13 = icmp slt i64 %12, %.0 37 | %14 = zext i1 %13 to i64 38 | %15 = icmp ne i64 %14, 0 39 | br i1 %15, label %16, label %18 40 | 41 | 16: ; preds = %11 42 | br label %17 43 | 44 | 17: ; preds = %16 45 | ret void 46 | 47 | 18: ; preds = %11 48 | %19 = load ptr, ptr %1, align 8 49 | %20 = getelementptr { i64, [0 x i64] }, ptr %19, i64 0, i64 0 50 | %21 = load i64, ptr %20, align 4 51 | %22 = icmp sge i64 %.0, 0 52 | %23 = icmp slt i64 %.0, %21 53 | %24 = and i1 %22, %23 54 | br i1 %24, label %25, label %30 55 | 56 | 25: ; preds = %18 57 | %26 = getelementptr { i64, [0 x i64] }, ptr %19, i64 0, i64 1, i64 %.0 58 | %27 = load i64, ptr %26, align 4 59 | call void @TIG_printi(i64 %27) 60 | call void @TIG_print(ptr @0) 61 | %28 = add i64 %.0, 1 62 | br label %29 63 | 64 | 29: ; preds = %25 65 | br label %11 66 | 67 | 30: ; preds = %18 68 | call void @TIG_bounds_error(ptr @1, i64 9, i64 15) 69 | unreachable 70 | 71 | 31: ; preds = %4 72 | %32 = load ptr, ptr %1, align 8 73 | %33 = getelementptr { i64, [0 x i64] }, ptr %32, i64 0, i64 0 74 | %34 = load i64, ptr %33, align 4 75 | %35 = icmp sge i64 %.01, 0 76 | %36 = icmp slt i64 %.01, %34 77 | %37 = and i1 %35, %36 78 | br i1 %37, label %38, label %42 79 | 80 | 38: ; preds = %31 81 | %39 = getelementptr { i64, [0 x i64] }, ptr %32, i64 0, i64 1, i64 %.01 82 | store i64 %.01, ptr %39, align 4 83 | %40 = add i64 %.01, 1 84 | br label %41 85 | 86 | 41: ; preds = %38 87 | br label %4 88 | 89 | 42: ; preds = %31 90 | call void @TIG_bounds_error(ptr @1, i64 7, i64 7) 91 | unreachable 92 | } 93 | 94 | ; Function Attrs: nounwind 95 | declare void @llvm.gcroot(ptr %0, ptr %1) #0 96 | 97 | declare ptr @TIG_makearray(i64 %0, i64 %1) 98 | 99 | declare void @TIG_printi(i64 %0) 100 | 101 | declare void @TIG_print(ptr %0) 102 | 103 | declare void @TIG_bounds_error(ptr %0, i64 %1, i64 %2) 104 | 105 | attributes #0 = { nounwind } 106 | -------------------------------------------------------------------------------- /src/parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Tabs 3 | %} 4 | 5 | %token ARRAY OF 6 | %token NIL BREAK 7 | %token COLON COMMA 8 | %token VAR FUNCTION TYPE 9 | %token COLONEQ 10 | %token LAND LOR 11 | %token EQ NE LE LT GE GT 12 | %token FOR WHILE TO DO 13 | %token PLUS MINUS TIMES SLASH 14 | %token SEMI 15 | %token DOT 16 | %token LET IN END 17 | %token IF THEN ELSE 18 | %token LCURLY RCURLY 19 | %token LBRACK RBRACK 20 | %token LPAREN RPAREN 21 | %token INT 22 | %token IDENT 23 | %token STRING 24 | %token EOF 25 | 26 | %start program 27 | 28 | %left THEN 29 | %left ELSE 30 | %nonassoc COLONEQ 31 | %left OF DO 32 | %left LOR 33 | %left LAND 34 | %nonassoc LE GE EQ NE GT LT 35 | %left PLUS MINUS 36 | %left TIMES SLASH 37 | %right unary_op 38 | 39 | %% 40 | 41 | program: exp EOF { {name = ""; body = $1} } 42 | ; 43 | 44 | %inline ident: loc(IDENT) { $1 } 45 | ; 46 | 47 | %inline binary_operation: 48 | | PLUS { Op_add } 49 | | TIMES { Op_mul } 50 | | MINUS { Op_sub } 51 | | SLASH { Op_div } 52 | | EQ { Op_cmp Ceq } 53 | | NE { Op_cmp Cne } 54 | | LE { Op_cmp Cle } 55 | | LT { Op_cmp Clt } 56 | | GE { Op_cmp Cge } 57 | | GT { Op_cmp Cgt } 58 | ; 59 | 60 | %inline loc(X): X { {desc = $1; loc = $symbolstartpos} } 61 | ; 62 | 63 | %inline exp: loc(exp_) { $1 } 64 | ; 65 | 66 | exp_: 67 | | INT { Eint $1 } 68 | | STRING { Estring $1 } 69 | | NIL { Enil } 70 | | MINUS exp %prec unary_op { Ebinop ({desc = Eint 0L; loc = $2.loc}, Op_sub, $2) } 71 | | exp LAND exp { Eif ($1, $3, Some {desc = Eint 0L; loc = $1.loc}) } 72 | | exp LOR exp { Eif ($1, {desc = Eint 1L; loc = $1.loc}, Some $3) } 73 | | exp binary_operation exp { Ebinop ($1, $2, $3) } 74 | | ident LPAREN separated_list(COMMA, exp) RPAREN { Ecall ($1, $3) } 75 | | LPAREN separated_list(SEMI, exp) RPAREN { Eseq $2 } 76 | | ident LCURLY separated_list(COMMA, separated_pair(ident, EQ, exp)) RCURLY 77 | { Erecord ($1, $3) } 78 | | var { Evar $1 } 79 | | var COLONEQ exp { Eassign ($1, $3) } 80 | | var LBRACK exp RBRACK OF exp 81 | { match $1.desc with 82 | | Vsimple x -> Earray (x, $3, $6) 83 | | _ -> assert false 84 | } 85 | | IF exp THEN exp ioption(preceded(ELSE, exp)) { Eif ($2, $4, $5) } 86 | | WHILE exp DO exp { Ewhile ($2, $4) } 87 | | FOR ident COLONEQ exp TO exp DO exp { Efor ($2, $4, $6, $8) } 88 | | BREAK { Ebreak } 89 | | LET nonempty_list(dec) IN loc(separated_list(SEMI, exp)) END { Elet ($2, {$4 with desc = Eseq $4.desc}) } 90 | ; 91 | 92 | %inline var: loc(var_) { $1 } 93 | ; 94 | 95 | var_: 96 | | ident { Vsimple $1 } 97 | | var LBRACK exp RBRACK { Vsubscript ($1, $3) } 98 | | var DOT ident { Vfield ($1, $3) } 99 | ; 100 | 101 | dec: 102 | | VAR ident option(preceded(COLON, ident)) COLONEQ exp { Dvar ($2, $3, $5) } 103 | | TYPE ident EQ typ { Dtype ($2, $4) } 104 | | FUNCTION ident 105 | LPAREN separated_list(COMMA, separated_pair(ident, COLON, ident)) RPAREN 106 | option(preceded(COLON, ident)) EQ exp 107 | { Dfun {fn_name = $2; fn_args = $4; fn_rtyp = $6; fn_body = $8} } 108 | ; 109 | 110 | typ: 111 | | ident { Tname $1 } 112 | | ARRAY OF ident { Tarray $3 } 113 | | LCURLY separated_list(COMMA, separated_pair(ident, COLON, ident)) RCURLY { Trecord $2 } 114 | ; 115 | 116 | -------------------------------------------------------------------------------- /src/main.ml: -------------------------------------------------------------------------------- 1 | let dump_llvm = ref false 2 | let opt_level = ref 1 3 | 4 | let () = 5 | Printexc.record_backtrace true 6 | 7 | let () = 8 | Llvm_all_backends.initialize () 9 | 10 | let target_machine = 11 | let triple = Llvm_target.Target.default_triple () in 12 | let target = Llvm_target.Target.by_triple triple in 13 | Llvm_target.TargetMachine.create ~triple ~reloc_mode:PIC target 14 | 15 | let opt m = 16 | if !opt_level <= 0 then m 17 | else begin 18 | let passes = ["mem2reg"] in 19 | let passes = if !opt_level >= 2 then "gvn" :: "adce" :: passes else passes in 20 | let options = Llvm_passbuilder.create_passbuilder_options () in 21 | let res = Llvm_passbuilder.run_passes m (String.concat "," passes) target_machine options in 22 | Llvm_passbuilder.dispose_passbuilder_options options; 23 | match res with 24 | | Ok () -> m 25 | | Error s -> failwith s 26 | end 27 | 28 | let lexbuf_from_file fn = 29 | let lexbuf = Lexing.from_string (In_channel.with_open_bin fn In_channel.input_all) in 30 | lexbuf.Lexing.lex_curr_p <- {lexbuf.Lexing.lex_curr_p with Lexing.pos_fname = fn}; 31 | lexbuf 32 | 33 | let write_object fn m = 34 | Llvm_target.TargetMachine.emit_to_file m ObjectFile (Filename.chop_extension fn ^ ".o") target_machine; 35 | m 36 | 37 | (* let write_bitcode_file fn m = 38 | let _ = Llvm_bitwriter.write_bitcode_file m (Filename.chop_extension fn ^ ".bc") in 39 | m *) 40 | 41 | let dump m = 42 | if !dump_llvm then Llvm.dump_module m; 43 | m 44 | 45 | exception Syntax_error of Lexing.position * Lexing.position 46 | 47 | let parse_program lexbuf = 48 | try 49 | Parser.program Lexer.token lexbuf 50 | with Parser.Error -> 51 | let start_pos = Lexing.lexeme_start_p lexbuf in 52 | let end_pos = Lexing.lexeme_end_p lexbuf in 53 | raise (Syntax_error (start_pos, end_pos)) 54 | 55 | let compile_file fn = 56 | fn 57 | |> lexbuf_from_file 58 | |> parse_program 59 | |> Typecheck.program 60 | |> Compile.program 61 | |> Irep.transl_program 62 | |> opt 63 | |> dump 64 | |> write_object fn 65 | |> Llvm.dispose_module 66 | 67 | let format_file fn = 68 | let lexbuf = lexbuf_from_file fn in 69 | let ast = Parser.program Lexer.token lexbuf in 70 | Format.printf "%a@." Fmt.expression ast.body 71 | 72 | type mode = 73 | | Fmt 74 | | Compile 75 | 76 | let mode = ref None 77 | 78 | let anonymous s = 79 | match !mode, s with 80 | | None, "fmt" -> mode := Some Fmt 81 | | None, ("c" | "compile") -> mode := Some Compile 82 | | (None | Some Compile), s -> compile_file s 83 | | Some Fmt, s -> format_file s 84 | 85 | let program_name = "tc" 86 | 87 | let main () = 88 | let spec = 89 | [ 90 | "-dllvm", Arg.Set dump_llvm, " Dump LLVM representation"; 91 | "-O0", Arg.Unit (fun () -> opt_level := 0), " Disable all optimizations"; 92 | "-O1", Arg.Unit (fun () -> opt_level := 1), " Minimal optimizations (default)"; 93 | "-O2", Arg.Unit (fun () -> opt_level := 2), " Further optimmizations"; 94 | ] 95 | in 96 | Arg.parse (Arg.align spec) anonymous "tigerc 0.1" 97 | 98 | let () = 99 | try 100 | main () 101 | with 102 | | Failure s | Sys_error s -> 103 | Printf.eprintf "%s: error: %s\n%!" program_name s; 104 | exit 1 105 | | Syntax_error (start_pos, _end_pos) -> 106 | let sourcefile = start_pos.Lexing.pos_fname in 107 | let lineno = start_pos.Lexing.pos_lnum in 108 | let column = start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol + 1 in 109 | Printf.eprintf "%s:%i:%i: syntax error\n%!" sourcefile lineno column; 110 | exit 2 111 | | Typecheck.Error {loc; desc} -> 112 | Printf.eprintf "error: %s:%i:%i: %s\n%!" 113 | loc.Lexing.pos_fname loc.Lexing.pos_lnum 114 | (loc.Lexing.pos_cnum - loc.Lexing.pos_bol + 1) (Typecheck.string_of_error desc); 115 | exit 3 116 | | exn -> 117 | Printf.eprintf "%s: unexpected error\n\n%s\n%!" program_name (Printexc.to_string exn); 118 | Printexc.print_backtrace stderr; 119 | exit 4 120 | -------------------------------------------------------------------------------- /tests/test007.err: -------------------------------------------------------------------------------- 1 | 2 | @0 = private unnamed_addr constant [16 x i8] c"PRIMES AT MOST \00", align 1 3 | @1 = private unnamed_addr constant [2 x i8] c"\0A\00", align 1 4 | @2 = private unnamed_addr constant [2 x i8] c" \00", align 1 5 | @3 = private unnamed_addr constant [12 x i8] c"test007.tig\00", align 1 6 | 7 | define void @TIG_main() gc "shadow-stack" { 8 | entry: 9 | %0 = alloca ptr, align 8 10 | store ptr null, ptr %0, align 8 11 | call void @llvm.gcroot(ptr %0, ptr null) 12 | %1 = alloca ptr, align 8 13 | store ptr null, ptr %1, align 8 14 | call void @llvm.gcroot(ptr %1, ptr null) 15 | %2 = add i64 500, 1 16 | %3 = call ptr @TIG_makearray(i64 %2, i64 1) 17 | store ptr %3, ptr %0, align 8 18 | %4 = load ptr, ptr %0, align 8 19 | store ptr %4, ptr %1, align 8 20 | call void @TIG_print(ptr @0) 21 | call void @TIG_printi(i64 500) 22 | call void @TIG_print(ptr @1) 23 | br label %5 24 | 25 | 5: ; preds = %entry, %32 26 | %.01 = phi i64 [ 2, %entry ], [ %31, %32 ] 27 | %6 = icmp slt i64 500, %.01 28 | %7 = zext i1 %6 to i64 29 | %8 = icmp ne i64 %7, 0 30 | br i1 %8, label %9, label %11 31 | 32 | 9: ; preds = %5 33 | br label %10 34 | 35 | 10: ; preds = %9 36 | call void @TIG_print(ptr @1) 37 | ret void 38 | 39 | 11: ; preds = %5 40 | %12 = load ptr, ptr %1, align 8 41 | %13 = getelementptr { i64, [0 x i64] }, ptr %12, i64 0, i64 0 42 | %14 = load i64, ptr %13, align 4 43 | %15 = icmp sge i64 %.01, 0 44 | %16 = icmp slt i64 %.01, %14 45 | %17 = and i1 %15, %16 46 | br i1 %17, label %18, label %47 47 | 48 | 18: ; preds = %11 49 | %19 = getelementptr { i64, [0 x i64] }, ptr %12, i64 0, i64 1, i64 %.01 50 | %20 = load i64, ptr %19, align 4 51 | %21 = icmp ne i64 %20, 0 52 | br i1 %21, label %22, label %46 53 | 54 | 22: ; preds = %18 55 | call void @TIG_printi(i64 %.01) 56 | call void @TIG_print(ptr @2) 57 | br label %23 58 | 59 | 23: ; preds = %22, %44 60 | %.0 = phi i64 [ %.01, %22 ], [ %43, %44 ] 61 | %24 = sdiv i64 500, %.01 62 | %25 = icmp slt i64 %24, %.0 63 | %26 = zext i1 %25 to i64 64 | %27 = icmp ne i64 %26, 0 65 | br i1 %27, label %28, label %33 66 | 67 | 28: ; preds = %23 68 | br label %29 69 | 70 | 29: ; preds = %28 71 | br label %30 72 | 73 | 30: ; preds = %46, %29 74 | %31 = add i64 %.01, 1 75 | br label %32 76 | 77 | 32: ; preds = %30 78 | br label %5 79 | 80 | 33: ; preds = %23 81 | %34 = mul i64 %.01, %.0 82 | %35 = load ptr, ptr %1, align 8 83 | %36 = getelementptr { i64, [0 x i64] }, ptr %35, i64 0, i64 0 84 | %37 = load i64, ptr %36, align 4 85 | %38 = icmp sge i64 %34, 0 86 | %39 = icmp slt i64 %34, %37 87 | %40 = and i1 %38, %39 88 | br i1 %40, label %41, label %45 89 | 90 | 41: ; preds = %33 91 | %42 = getelementptr { i64, [0 x i64] }, ptr %35, i64 0, i64 1, i64 %34 92 | store i64 0, ptr %42, align 4 93 | %43 = add i64 %.0, 1 94 | br label %44 95 | 96 | 44: ; preds = %41 97 | br label %23 98 | 99 | 45: ; preds = %33 100 | call void @TIG_bounds_error(ptr @3, i64 10, i64 30) 101 | unreachable 102 | 103 | 46: ; preds = %18 104 | br label %30 105 | 106 | 47: ; preds = %11 107 | call void @TIG_bounds_error(ptr @3, i64 8, i64 10) 108 | unreachable 109 | } 110 | 111 | ; Function Attrs: nounwind 112 | declare void @llvm.gcroot(ptr %0, ptr %1) #0 113 | 114 | declare ptr @TIG_makearray(i64 %0, i64 %1) 115 | 116 | declare void @TIG_print(ptr %0) 117 | 118 | declare void @TIG_printi(i64 %0) 119 | 120 | declare void @TIG_bounds_error(ptr %0, i64 %1, i64 %2) 121 | 122 | attributes #0 = { nounwind } 123 | -------------------------------------------------------------------------------- /runtime/tiger_gc.c: -------------------------------------------------------------------------------- 1 | /*===-- semispace.c - Simple semi-space copying garbage collector ---------===*\ 2 | |* 3 | |* The LLVM Compiler Infrastructure 4 | |* 5 | |* This file was developed by the LLVM research group and is distributed under 6 | |* the University of Illinois Open Source License. See LICENSE.TXT for details. 7 | |* 8 | |*===----------------------------------------------------------------------===*| 9 | |* 10 | |* This garbage collector is an extremely simple copying collector. It splits 11 | |* the managed region of memory into two pieces: the current space to allocate 12 | |* from, and the copying space. When the portion being allocated from fills up, 13 | |* a garbage collection cycle happens, which copies all live blocks to the other 14 | |* half of the managed space. 15 | |* 16 | \*===----------------------------------------------------------------------===*/ 17 | 18 | #include 19 | #include 20 | #include 21 | 22 | /* AllocPtr - This points to the next byte that is available for allocation. 23 | */ 24 | static char *AllocPtr; 25 | 26 | /* AllocEnd - This points to the first byte not available for allocation. When 27 | * AllocPtr passes this, we have run out of space. 28 | */ 29 | static char *AllocEnd; 30 | 31 | /* CurSpace/OtherSpace - These pointers point to the two regions of memory that 32 | * we switch between. The unallocated portion of the CurSpace is known to be 33 | * zero'd out, but the OtherSpace contains junk. 34 | */ 35 | static void *CurSpace, *OtherSpace; 36 | 37 | /* SpaceSize - The size of each space. */ 38 | static unsigned SpaceSize; 39 | 40 | /* llvm_gc_initialize - Allocate the two spaces that we plan to switch between. 41 | */ 42 | void llvm_gc_initialize(unsigned InitialHeapSize) { 43 | printf ("initializing gc with %d bytes\n", InitialHeapSize); 44 | SpaceSize = InitialHeapSize/2; 45 | CurSpace = AllocPtr = calloc(1, SpaceSize); 46 | OtherSpace = malloc(SpaceSize); 47 | AllocEnd = AllocPtr + SpaceSize; 48 | } 49 | 50 | /* We always want to inline the fast path, but never want to inline the slow 51 | * path. 52 | */ 53 | void *llvm_gc_allocate(unsigned Size) __attribute__((always_inline)); 54 | static void* llvm_gc_alloc_slow(unsigned Size) __attribute__((noinline)); 55 | 56 | /* GC */ 57 | 58 | typedef struct FrameMap { 59 | int32_t NumRoots; //< Number of roots in stack frame. 60 | int32_t NumMeta; //< Number of metadata entries. May be < NumRoots. 61 | const void *Meta[0]; //< Metadata for each root. 62 | } FrameMap; 63 | 64 | typedef struct StackEntry { 65 | struct StackEntry *Next; //< Link to next stack entry (the caller's). 66 | const FrameMap *Map; //< Pointer to constant FrameMap. 67 | void *Roots[0]; //< Stack roots (in-place array). 68 | } StackEntry; 69 | 70 | StackEntry *llvm_gc_root_chain; 71 | 72 | void visitGCRoots(void (*Visitor)(void **Root, const void *Meta)) { 73 | unsigned i; 74 | unsigned e; 75 | 76 | for (StackEntry *R = llvm_gc_root_chain; R; R = R->Next) { 77 | i = 0; 78 | 79 | // For roots [0, NumMeta), the metadata pointer is in the FrameMap. 80 | for (e = R->Map->NumMeta; i != e; ++i) 81 | Visitor(&R->Roots[i], R->Map->Meta[i]); 82 | 83 | // For roots [NumMeta, NumRoots), the metadata pointer is null. 84 | for (e = R->Map->NumRoots; i != e; ++i) 85 | Visitor(&R->Roots[i], NULL); 86 | } 87 | } 88 | 89 | static void process_pointer(void **Root, const void *Meta) { 90 | /* printf("process_root[0x%p] = 0x%p meta=%c\n", (void*) Root, (void*) *Root, * (char *) Meta); */ 91 | printf("process_root[%p] = %p\n", (void*) Root, (void*) *Root); 92 | } 93 | 94 | void llvm_gc_collect() { 95 | // Clear out the space we will be copying into. 96 | // FIXME: This should do the copy, then clear out whatever space is left. 97 | memset(OtherSpace, 0, SpaceSize); 98 | 99 | printf("Garbage collecting!!\n"); 100 | 101 | visitGCRoots (process_pointer); 102 | } 103 | 104 | void *llvm_gc_allocate(unsigned Size) { 105 | char *OldAP = AllocPtr; 106 | char *NewEnd = OldAP+Size; 107 | printf ("allocating %d bytes\n", Size); 108 | if (NewEnd > AllocEnd) 109 | return llvm_gc_alloc_slow(Size); 110 | AllocPtr = NewEnd; 111 | return OldAP; 112 | } 113 | 114 | static void* llvm_gc_alloc_slow(unsigned Size) { 115 | llvm_gc_collect(); 116 | 117 | if (AllocPtr+Size > AllocEnd) { 118 | fprintf(stderr, "Garbage collector ran out of memory " 119 | "allocating object of size: %d\n", Size); 120 | exit(1); 121 | } 122 | 123 | return llvm_gc_allocate(Size); 124 | } 125 | 126 | #define INITIAL_HEAP_SIZE 10000 127 | 128 | void __tiger__main (void); 129 | 130 | int main (void) 131 | { 132 | char* initial_heap_size = getenv ("TIGERHEAPSIZE"); 133 | if (initial_heap_size != NULL) { 134 | llvm_gc_initialize (atoi (initial_heap_size)); 135 | } else { 136 | llvm_gc_initialize (INITIAL_HEAP_SIZE); 137 | }; 138 | 139 | __tiger__main (); 140 | 141 | return 0; 142 | } 143 | -------------------------------------------------------------------------------- /src/irep.ml: -------------------------------------------------------------------------------- 1 | open Llvm 2 | 3 | type ty = 4 | | Tvoid 5 | | Tstruct of ty list 6 | | Tarray of ty * int 7 | | Tnamed of string 8 | | Tpointer 9 | | Tint of int 10 | 11 | type signature = ty list * ty 12 | 13 | type operation = 14 | | Pconstint of int64 15 | | Pconststring of string 16 | | Pnull 17 | | Pparam of int 18 | | Paddint 19 | | Psubint 20 | | Pmulint 21 | | Pdivint 22 | | Pgep of ty 23 | | Pcmpint of Tabs.comparison 24 | | Pand 25 | | Pzext 26 | | Ialloca of ty * bool 27 | | Iexternal of string * signature 28 | | Icall of Typing.ident 29 | | Imakearray 30 | | Imakerecord of int 31 | 32 | module Reg = struct 33 | type t = int 34 | type state = int ref 35 | let create () = ref 0 36 | let next state = incr state; !state 37 | module Map = Map.Make(Int) 38 | end 39 | 40 | module Label = struct 41 | type t = int 42 | type state = int ref 43 | let create () = ref 0 44 | let next state = incr state; !state 45 | module Map = Map.Make(Int) 46 | module Tbl = Hashtbl.Make(Int) 47 | end 48 | 49 | type reg = Reg.t 50 | 51 | type label = Label.t 52 | 53 | type instruction = 54 | | Iop of operation * reg list * reg * instruction 55 | | Iload of ty * reg * reg * instruction 56 | | Istore of reg * reg * instruction 57 | | Iifthenelse of reg * label * label 58 | | Igoto of label 59 | | Ireturn of reg option 60 | | Iunreachable 61 | 62 | type fundef = 63 | { 64 | name: Typing.fundef_name; 65 | signature: signature; 66 | code: instruction Label.Map.t; 67 | entrypoint: instruction; 68 | } 69 | 70 | type program = 71 | { 72 | funs: fundef list; 73 | } 74 | 75 | let intptr_type c = 76 | assert (Sys.word_size = 64); 77 | i64_type c 78 | 79 | type env = 80 | { 81 | c: llcontext; 82 | m: llmodule; 83 | b: llbuilder; 84 | f: llvalue; 85 | strings: (string, llvalue) Hashtbl.t; 86 | code: instruction Label.Map.t; 87 | blocks: llbasicblock Label.Tbl.t; 88 | regs: llvalue Reg.Map.t; 89 | funs: (llvalue * lltype) Typing.Ident.Map.t; 90 | } 91 | 92 | let rec transl_ty c ty = 93 | match ty with 94 | | Tvoid -> 95 | void_type c 96 | | Tarray (ty, len) -> 97 | array_type (transl_ty c ty) len 98 | | Tstruct tys -> 99 | struct_type c (Array.of_list (List.map (transl_ty c) tys)) 100 | | Tnamed name -> 101 | named_struct_type c name 102 | | Tpointer -> 103 | pointer_type c 104 | | Tint width -> 105 | integer_type c width 106 | 107 | let gcroot env v = 108 | let lltype = function_type (void_type env.c) [|pointer_type env.c; pointer_type env.c|] in 109 | let f = declare_function "llvm.gcroot" lltype env.m in 110 | ignore (build_call lltype f [|v; const_null (pointer_type env.c)|] "" env.b) 111 | 112 | let transl_operation env op args = 113 | match op, args with 114 | | Pconstint n, [] -> 115 | const_of_int64 (intptr_type env.c) n false 116 | | Pconststring s, [] -> 117 | begin match Hashtbl.find_opt env.strings s with 118 | | Some v -> v 119 | | None -> 120 | let v = build_global_stringptr s "" env.b in 121 | Hashtbl.replace env.strings s v; 122 | v 123 | end 124 | | Pnull, [] -> 125 | const_null (pointer_type env.c) 126 | | Pparam i, [] -> 127 | param env.f i 128 | | Paddint, [arg1; arg2] -> 129 | build_add arg1 arg2 "" env.b 130 | | Psubint, [arg1; arg2] -> 131 | build_sub arg1 arg2 "" env.b 132 | | Pmulint, [arg1; arg2] -> 133 | build_mul arg1 arg2 "" env.b 134 | | Pdivint, [arg1; arg2] -> 135 | build_sdiv arg1 arg2 "" env.b 136 | | Pcmpint c, [r1; r2] -> 137 | let c = 138 | match c with 139 | | Ceq -> Icmp.Eq | Cne -> Icmp.Ne | Cle -> Icmp.Sle 140 | | Clt -> Icmp.Slt | Cge -> Icmp.Sge | Cgt -> Icmp.Sgt 141 | in 142 | build_icmp c r1 r2 "" env.b 143 | | Pand, [r1; r2] -> 144 | build_and r1 r2 "" env.b 145 | | Pzext, [r] -> 146 | build_zext r (intptr_type env.c) "" env.b 147 | | Pgep ty, (r0 :: rl) -> 148 | build_gep (transl_ty env.c ty) r0 (Array.of_list rl) "" env.b 149 | | Ialloca (ty, root), [] -> 150 | let v = build_alloca (transl_ty env.c ty) "" env.b in 151 | if root then begin 152 | ignore (build_store (const_null (pointer_type env.c)) v env.b); 153 | gcroot env v; 154 | end; 155 | v 156 | | Iexternal (f, (tys, ty)), args -> 157 | let lltype = function_type (transl_ty env.c ty) (Array.of_list (List.map (transl_ty env.c) tys)) in 158 | let f = declare_function f lltype env.m in 159 | build_call lltype f (Array.of_list args) "" env.b 160 | | Icall f, args -> 161 | let f, sg = Typing.Ident.Map.find f env.funs in 162 | build_call sg f (Array.of_list args) "" env.b 163 | | Imakearray, [size; init] -> 164 | let ty = function_type (pointer_type env.c) [|intptr_type env.c; intptr_type env.c|] in 165 | let f = declare_function "TIG_makearray" ty env.m in 166 | build_call ty f [|size; init|] "" env.b 167 | | Imakerecord n, [] -> 168 | let ty = function_type (pointer_type env.c) [|i32_type env.c|] in 169 | let f = declare_function "TIG_makerecord" ty env.m in 170 | build_call ty f [|const_int (i32_type env.c) n|] "" env.b 171 | | (Pconstint _ | Pconststring _ | Pnull | 172 | Pparam _ | Paddint | Psubint | Pmulint | Pdivint | Pcmpint _ | 173 | Pand | Pzext | Pgep _ | Ialloca _ | Imakearray | 174 | Imakerecord _ ), _ -> 175 | assert false 176 | 177 | let add_var env reg v = 178 | {env with regs = Reg.Map.add reg v env.regs} 179 | 180 | let find_var env reg = 181 | Reg.Map.find reg env.regs 182 | 183 | let find_code env lbl = 184 | Label.Map.find lbl env.code 185 | 186 | let rec transl_instr env i = 187 | match i with 188 | | Iop (op, args, res, next) -> 189 | let args = List.map (find_var env) args in 190 | let vres = transl_operation env op args in 191 | transl_instr (add_var env res vres) next 192 | | Iload (ty, arg, res, next) -> 193 | let v = build_load (transl_ty env.c ty) (find_var env arg) "" env.b in 194 | transl_instr (add_var env res v) next 195 | | Istore (src, dst, next) -> 196 | ignore (build_store (find_var env src) (find_var env dst) env.b); 197 | transl_instr env next 198 | | Iifthenelse (cond, ifso, ifnot) -> 199 | let bbyay = transl_block env ifso in 200 | let bbnay = transl_block env ifnot in 201 | ignore (build_cond_br (find_var env cond) bbyay bbnay env.b) 202 | | Igoto lbl -> 203 | let bb = transl_block env lbl in 204 | ignore (build_br bb env.b) 205 | | Ireturn (Some arg) -> 206 | ignore (build_ret (find_var env arg) env.b) 207 | | Ireturn None -> 208 | ignore (build_ret_void env.b) 209 | | Iunreachable -> 210 | ignore (build_unreachable env.b) 211 | 212 | and transl_block env lbl = 213 | match Label.Tbl.find_opt env.blocks lbl with 214 | | Some bb -> bb 215 | | None -> 216 | let bb = append_block env.c "" env.f in 217 | Label.Tbl.add env.blocks lbl bb; 218 | let b = builder env.c in 219 | position_at_end bb b; 220 | transl_instr {env with b} (find_code env lbl); 221 | bb 222 | 223 | let transl_fundefs c m fdefs = 224 | let fs = 225 | List.map (fun fdef -> 226 | let args, rety = fdef.signature in 227 | let rety = transl_ty c rety in 228 | let args = List.map (transl_ty c) args in 229 | let sg = function_type rety (Array.of_list args) in 230 | let name = 231 | match fdef.name with Main -> "TIG_main" | Internal id -> Typing.Ident.unique_name id in 232 | let f = define_function name sg m in 233 | set_gc (Some "shadow-stack") f; 234 | f, sg 235 | ) fdefs 236 | in 237 | let funs = 238 | List.fold_left2 (fun funs fdef (f, sg) -> 239 | match fdef.name with 240 | | Main -> funs 241 | | Internal name -> Typing.Ident.Map.add name (f, sg) funs 242 | ) Typing.Ident.Map.empty fdefs fs 243 | in 244 | let strings = Hashtbl.create 0 in 245 | List.iter2 (fun (fdef : fundef) (f, _) -> 246 | let b = builder c in 247 | let env = { c; m; b; f; strings; code = fdef.code; blocks = Label.Tbl.create 0; regs = Reg.Map.empty; funs } in 248 | position_at_end (entry_block f) b; 249 | transl_instr env fdef.entrypoint 250 | ) fdefs fs 251 | 252 | let transl_program (p : program) = 253 | let c = global_context () in 254 | let m = create_module c "" in 255 | transl_fundefs c m p.funs; 256 | m 257 | -------------------------------------------------------------------------------- /src/compile.ml: -------------------------------------------------------------------------------- 1 | open Typing 2 | open Irep 3 | 4 | type env = 5 | { 6 | cstrs: type_structure Typing.Ident.Map.t; 7 | next_reg: Reg.state; 8 | next_label: Label.state; 9 | mutable blocks: instruction Label.Map.t; 10 | vars: reg Ident.Map.t; 11 | } 12 | 13 | let reg_of_var env id = 14 | Ident.Map.find id env.vars 15 | 16 | let new_reg env = 17 | Reg.next env.next_reg 18 | 19 | let new_label env = 20 | Label.next env.next_label 21 | 22 | let set_label env lbl i = 23 | env.blocks <- Label.Map.add lbl i env.blocks 24 | 25 | let label_instr env i = 26 | let lbl = new_label env in 27 | env.blocks <- Label.Map.add lbl i env.blocks; 28 | lbl 29 | 30 | let type_id : type_id -> ty = function 31 | | Tint -> Tint 64 32 | | Tstring | Tconstr _ -> Tpointer 33 | 34 | let type_structure env : type_id -> ty = function 35 | | Tint | Tstring -> assert false 36 | | Tconstr cstr -> 37 | Tstruct ( 38 | match Ident.Map.find cstr env.cstrs with 39 | | Tarray tid -> [Tint 64; Tarray (type_id tid, 0)] 40 | | Trecord l -> List.map (fun (_, tid) -> type_id tid) l 41 | ) 42 | 43 | let signature (args, res) = 44 | List.map type_id args, match res with None -> Tvoid | Some t -> type_id t 45 | 46 | let load env ty r next = 47 | let r' = new_reg env in 48 | Iload (ty, r, r', next r') 49 | 50 | let op env op args next = 51 | let r = new_reg env in 52 | Iop(op, args, r, next r) 53 | 54 | let int64 env n next = 55 | op env (Pconstint n) [] next 56 | 57 | let int env n next = 58 | int64 env (Int64.of_int n) next 59 | 60 | let string env s next = 61 | op env (Pconststring s) [] next 62 | 63 | let null env next = 64 | op env Pnull [] next 65 | 66 | let nil_error env loc = 67 | string env loc.filename @@ fun filename -> 68 | int env loc.lineno @@ fun lineno -> 69 | int env loc.column @@ fun column -> 70 | op env 71 | (Iexternal ("TIG_nil_error", ([Tpointer; Tint 64; Tint 64], Tvoid))) 72 | [filename; lineno; column] (fun _ -> Iunreachable) 73 | 74 | let null_check env loc v next = 75 | let lnext = label_instr env next in 76 | let lnull = label_instr env (nil_error env loc) in 77 | null env @@ fun z -> 78 | op env (Pcmpint Ceq) [v; z] @@ fun c -> 79 | Iifthenelse (c, lnull, lnext) 80 | 81 | let bounds_error env loc = 82 | string env loc.filename @@ fun filename -> 83 | int env loc.lineno @@ fun lineno -> 84 | int env loc.column @@ fun column -> 85 | op env 86 | (Iexternal ("TIG_bounds_error", ([Tpointer; Tint 64; Tint 64], Tvoid))) 87 | [filename; lineno; column] (fun _ -> Iunreachable) 88 | 89 | let bounds_check env loc ty v' i' next = 90 | let lnext = label_instr env next in 91 | let louts = label_instr env (bounds_error env loc) in 92 | int env 0 @@ fun z' -> 93 | op env (Pgep ty) [v'; z'; z'] @@ fun n' -> 94 | load env (Tint 64) n' @@ fun n' -> 95 | op env (Pcmpint Cge) [i'; z'] @@ fun c1' -> 96 | op env (Pcmpint Clt) [i'; n'] @@ fun c2' -> 97 | op env Pand [c1'; c2'] @@ fun c' -> 98 | Iifthenelse (c', lnext, louts) 99 | 100 | let rec variable env v next = 101 | match v.desc with 102 | | Vsimple x -> 103 | next (reg_of_var env x) 104 | | Vsubscript (loc, v, i) -> 105 | variable env v @@ fun v' -> 106 | expression env i @@ fun i' -> 107 | load env Tpointer v' @@ fun v' -> 108 | let ty = type_structure env v.ty in 109 | bounds_check env loc ty v' i' @@ 110 | int env 0 @@ fun zero' -> 111 | int env 1 @@ fun one' -> 112 | op env (Pgep ty) [v'; zero'; one'; i'] next 113 | | Vfield (loc, v, i) -> 114 | variable env v @@ fun v' -> 115 | int env i @@ fun i' -> 116 | int env 0 @@ fun zero' -> 117 | load env Tpointer v' @@ fun v' -> 118 | null_check env loc v' @@ 119 | op env (Pgep (type_structure env v.ty)) [v'; zero'; i'] next 120 | 121 | and expression env (e : expression) (next : reg -> instruction) = 122 | match e.desc with 123 | | Eint n -> 124 | int64 env n next 125 | | Estring s -> 126 | string env s next 127 | | Enil -> 128 | null env next 129 | | Evar v -> 130 | variable env v @@ fun v' -> 131 | load env (type_id v.ty) v' next 132 | | Ebinop (e1, Op_add, e2) -> 133 | expression env e1 @@ fun r1 -> 134 | expression env e2 @@ fun r2 -> 135 | op env Paddint [r1; r2] next 136 | | Ebinop (e1, Op_sub, e2) -> 137 | expression env e1 @@ fun r1 -> 138 | expression env e2 @@ fun r2 -> 139 | op env Psubint [r1; r2] next 140 | | Ebinop (e1, Op_mul, e2) -> 141 | expression env e1 @@ fun r1 -> 142 | expression env e2 @@ fun r2 -> 143 | op env Pmulint [r1; r2] next 144 | | Ebinop (e1, Op_div, e2) -> 145 | expression env e1 @@ fun r1 -> 146 | expression env e2 @@ fun r2 -> 147 | op env Pdivint[r1; r2] next 148 | | Ebinop (e1, Op_cmp c, e2) -> 149 | expression env e1 @@ fun r1 -> 150 | expression env e2 @@ fun r2 -> 151 | op env (Pcmpint c) [r1; r2] @@ fun rd -> 152 | op env Pzext [rd] next 153 | 154 | and statement env lexit s next = 155 | match s with 156 | | Sskip -> 157 | next 158 | | Sloop body -> 159 | let lnext = label_instr env next in 160 | let lbody = new_label env in 161 | set_label env lbody (statement env (Some lnext) body (Igoto lbody)); 162 | Igoto lbody 163 | | Sbreak -> 164 | Igoto (Option.get lexit) 165 | | Sifthenelse (e1, s2, s3) -> 166 | let lnext = label_instr env next in 167 | let lyes = label_instr env (statement env lexit s2 (Igoto lnext)) in 168 | let lnay = label_instr env (statement env lexit s3 (Igoto lnext)) in 169 | expression env e1 @@ fun r1 -> 170 | int env 0 @@ fun r2 -> 171 | op env (Pcmpint Tabs.Cne) [r1; r2] @@ fun r -> 172 | Iifthenelse (r, lyes, lnay) 173 | | Sseq (s1, s2) -> 174 | statement env lexit s1 (statement env lexit s2 next) 175 | | Sassign (v, e) -> 176 | variable env v @@ fun v' -> 177 | expression env e @@ fun e' -> 178 | Istore (e', v', next) 179 | | Scall (v, impl, el, sg) -> 180 | let rec loop rl = function 181 | | e :: el -> 182 | expression env e @@ fun r -> loop (r :: rl) el 183 | | [] -> 184 | let r = new_reg env in 185 | let next = 186 | match v with 187 | | None -> next 188 | | Some v -> variable env v @@ fun v' -> Istore (r, v', next) 189 | in 190 | let op = 191 | match impl with 192 | | External s -> Iexternal (s, signature sg) 193 | | Internal id -> Icall id 194 | in 195 | Iop (op, List.rev rl, r, next) 196 | in 197 | loop [] el 198 | | Sreturn (Some e) -> 199 | expression env e @@ fun r -> 200 | Ireturn (Some r) 201 | | Sreturn None -> 202 | Ireturn None 203 | | Sarray (v, size, init) -> 204 | expression env size @@ fun rsize -> 205 | expression env init @@ fun rinit -> 206 | variable env v @@ fun rv -> 207 | op env Imakearray [rsize; rinit] @@ fun rd -> 208 | Istore (rd, rv, next) 209 | | Srecord (v, fl) -> 210 | let n = List.length fl in 211 | let ty = type_structure env v.ty in 212 | op env (Imakerecord n) [] @@ fun rr -> 213 | let rec loop rl = function 214 | | [] -> 215 | variable env v @@ fun v' -> 216 | let _, stores = 217 | List.fold_left (fun (i, next) r -> 218 | i+1, 219 | int env (n - i - 1) @@ fun i' -> 220 | int env 0 @@ fun zero' -> 221 | op env (Pgep ty) [rr; zero'; i'] @@ fun rd -> 222 | Istore (r, rd, next) 223 | ) (0, Istore (rr, v', next)) rl 224 | in 225 | stores 226 | | e :: fl -> 227 | expression env e @@ fun r -> 228 | loop (r :: rl) fl 229 | in 230 | loop [] fl 231 | 232 | let fundef cstrs fundef = 233 | let next_reg = Reg.create () in 234 | let vars = 235 | let vars = ref Ident.Map.empty in 236 | List.iter (fun (s, _) -> vars := Ident.Map.add s (Reg.next next_reg) !vars) fundef.fn_args; 237 | List.iter (fun (s, _) -> vars := Ident.Map.add s (Reg.next next_reg) !vars) fundef.fn_vars; 238 | !vars 239 | in 240 | let env = { cstrs; next_reg; next_label = Label.create (); blocks = Label.Map.empty; vars } in 241 | let entrypoint = statement env None fundef.fn_body (Ireturn None) in 242 | let entrypoint = 243 | List.fold_left (fun next (name, tid) -> 244 | let root = match tid with Tconstr _ | Tstring -> true | Tint -> false in 245 | Iop (Ialloca (type_id tid, root), [], Ident.Map.find name vars, next) 246 | ) entrypoint fundef.fn_vars 247 | in 248 | let _, entrypoint = 249 | List.fold_left (fun (i, next) (name, tid) -> 250 | let root = match tid with Tconstr _ | Tstring -> true | Tint -> false in 251 | let r = Reg.next next_reg in 252 | let next = Iop (Pparam i, [], r, Istore (r, Ident.Map.find name vars, next)) in 253 | i+1, Iop (Ialloca (type_id tid, root), [], Ident.Map.find name vars, next) 254 | ) (0, entrypoint) fundef.fn_args 255 | in 256 | let sg = List.map (fun (_, ty) -> ty) fundef.fn_args, fundef.fn_rtyp in 257 | { name = fundef.fn_name; signature = signature sg; code = env.blocks; entrypoint } 258 | 259 | let program { cstr; funs } = 260 | let cstrs = Ident.Map.of_list cstr in 261 | let funs = List.map (fundef cstrs) funs in 262 | { funs } 263 | -------------------------------------------------------------------------------- /tests/dune.inc: -------------------------------------------------------------------------------- 1 | 2 | (rule 3 | (targets test028.out.gen test028.err.gen) 4 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test028.out.gen -err test028.err.gen %{dep:test028.tig}))) 5 | 6 | (rule 7 | (alias runtest) 8 | (action (diff test028.out test028.out.gen))) 9 | 10 | (rule 11 | (alias runtest) 12 | (action (diff test028.err test028.err.gen))) 13 | 14 | (rule 15 | (targets test013.out.gen test013.err.gen) 16 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test013.out.gen -err test013.err.gen %{dep:test013.tig}))) 17 | 18 | (rule 19 | (alias runtest) 20 | (action (diff test013.out test013.out.gen))) 21 | 22 | (rule 23 | (alias runtest) 24 | (action (diff test013.err test013.err.gen))) 25 | 26 | (rule 27 | (targets test024.out.gen test024.err.gen) 28 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test024.out.gen -err test024.err.gen %{dep:test024.tig}))) 29 | 30 | (rule 31 | (alias runtest) 32 | (action (diff test024.out test024.out.gen))) 33 | 34 | (rule 35 | (alias runtest) 36 | (action (diff test024.err test024.err.gen))) 37 | 38 | (rule 39 | (targets test020.out.gen test020.err.gen) 40 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test020.out.gen -err test020.err.gen %{dep:test020.tig}))) 41 | 42 | (rule 43 | (alias runtest) 44 | (action (diff test020.out test020.out.gen))) 45 | 46 | (rule 47 | (alias runtest) 48 | (action (diff test020.err test020.err.gen))) 49 | 50 | (rule 51 | (targets test003.out.gen test003.err.gen) 52 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test003.out.gen -err test003.err.gen %{dep:test003.tig}))) 53 | 54 | (rule 55 | (alias runtest) 56 | (action (diff test003.out test003.out.gen))) 57 | 58 | (rule 59 | (alias runtest) 60 | (action (diff test003.err test003.err.gen))) 61 | 62 | (rule 63 | (targets test015.out.gen test015.err.gen) 64 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test015.out.gen -err test015.err.gen %{dep:test015.tig}))) 65 | 66 | (rule 67 | (alias runtest) 68 | (action (diff test015.out test015.out.gen))) 69 | 70 | (rule 71 | (alias runtest) 72 | (action (diff test015.err test015.err.gen))) 73 | 74 | (rule 75 | (targets test026.out.gen test026.err.gen) 76 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test026.out.gen -err test026.err.gen %{dep:test026.tig}))) 77 | 78 | (rule 79 | (alias runtest) 80 | (action (diff test026.out test026.out.gen))) 81 | 82 | (rule 83 | (alias runtest) 84 | (action (diff test026.err test026.err.gen))) 85 | 86 | (rule 87 | (targets test007.out.gen test007.err.gen) 88 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test007.out.gen -err test007.err.gen %{dep:test007.tig}))) 89 | 90 | (rule 91 | (alias runtest) 92 | (action (diff test007.out test007.out.gen))) 93 | 94 | (rule 95 | (alias runtest) 96 | (action (diff test007.err test007.err.gen))) 97 | 98 | (rule 99 | (targets test033.out.gen test033.err.gen) 100 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test033.out.gen -err test033.err.gen %{dep:test033.tig}))) 101 | 102 | (rule 103 | (alias runtest) 104 | (action (diff test033.out test033.out.gen))) 105 | 106 | (rule 107 | (alias runtest) 108 | (action (diff test033.err test033.err.gen))) 109 | 110 | (rule 111 | (targets test031.out.gen test031.err.gen) 112 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test031.out.gen -err test031.err.gen %{dep:test031.tig}))) 113 | 114 | (rule 115 | (alias runtest) 116 | (action (diff test031.out test031.out.gen))) 117 | 118 | (rule 119 | (alias runtest) 120 | (action (diff test031.err test031.err.gen))) 121 | 122 | (rule 123 | (targets test016.out.gen test016.err.gen) 124 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test016.out.gen -err test016.err.gen %{dep:test016.tig}))) 125 | 126 | (rule 127 | (alias runtest) 128 | (action (diff test016.out test016.out.gen))) 129 | 130 | (rule 131 | (alias runtest) 132 | (action (diff test016.err test016.err.gen))) 133 | 134 | (rule 135 | (targets test014.out.gen test014.err.gen) 136 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test014.out.gen -err test014.err.gen %{dep:test014.tig}))) 137 | 138 | (rule 139 | (alias runtest) 140 | (action (diff test014.out test014.out.gen))) 141 | 142 | (rule 143 | (alias runtest) 144 | (action (diff test014.err test014.err.gen))) 145 | 146 | (rule 147 | (targets test002.out.gen test002.err.gen) 148 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test002.out.gen -err test002.err.gen %{dep:test002.tig}))) 149 | 150 | (rule 151 | (alias runtest) 152 | (action (diff test002.out test002.out.gen))) 153 | 154 | (rule 155 | (alias runtest) 156 | (action (diff test002.err test002.err.gen))) 157 | 158 | (rule 159 | (targets test018.out.gen test018.err.gen) 160 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test018.out.gen -err test018.err.gen %{dep:test018.tig}))) 161 | 162 | (rule 163 | (alias runtest) 164 | (action (diff test018.out test018.out.gen))) 165 | 166 | (rule 167 | (alias runtest) 168 | (action (diff test018.err test018.err.gen))) 169 | 170 | (rule 171 | (targets test019.out.gen test019.err.gen) 172 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test019.out.gen -err test019.err.gen %{dep:test019.tig}))) 173 | 174 | (rule 175 | (alias runtest) 176 | (action (diff test019.out test019.out.gen))) 177 | 178 | (rule 179 | (alias runtest) 180 | (action (diff test019.err test019.err.gen))) 181 | 182 | (rule 183 | (targets test017.out.gen test017.err.gen) 184 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test017.out.gen -err test017.err.gen %{dep:test017.tig}))) 185 | 186 | (rule 187 | (alias runtest) 188 | (action (diff test017.out test017.out.gen))) 189 | 190 | (rule 191 | (alias runtest) 192 | (action (diff test017.err test017.err.gen))) 193 | 194 | (rule 195 | (targets test009.out.gen test009.err.gen) 196 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test009.out.gen -err test009.err.gen %{dep:test009.tig}))) 197 | 198 | (rule 199 | (alias runtest) 200 | (action (diff test009.out test009.out.gen))) 201 | 202 | (rule 203 | (alias runtest) 204 | (action (diff test009.err test009.err.gen))) 205 | 206 | (rule 207 | (targets test005.out.gen test005.err.gen) 208 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test005.out.gen -err test005.err.gen %{dep:test005.tig}))) 209 | 210 | (rule 211 | (alias runtest) 212 | (action (diff test005.out test005.out.gen))) 213 | 214 | (rule 215 | (alias runtest) 216 | (action (diff test005.err test005.err.gen))) 217 | 218 | (rule 219 | (targets test027.out.gen test027.err.gen) 220 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test027.out.gen -err test027.err.gen %{dep:test027.tig}))) 221 | 222 | (rule 223 | (alias runtest) 224 | (action (diff test027.out test027.out.gen))) 225 | 226 | (rule 227 | (alias runtest) 228 | (action (diff test027.err test027.err.gen))) 229 | 230 | (rule 231 | (targets test021.out.gen test021.err.gen) 232 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test021.out.gen -err test021.err.gen %{dep:test021.tig}))) 233 | 234 | (rule 235 | (alias runtest) 236 | (action (diff test021.out test021.out.gen))) 237 | 238 | (rule 239 | (alias runtest) 240 | (action (diff test021.err test021.err.gen))) 241 | 242 | (rule 243 | (targets test032.out.gen test032.err.gen) 244 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test032.out.gen -err test032.err.gen %{dep:test032.tig}))) 245 | 246 | (rule 247 | (alias runtest) 248 | (action (diff test032.out test032.out.gen))) 249 | 250 | (rule 251 | (alias runtest) 252 | (action (diff test032.err test032.err.gen))) 253 | 254 | (rule 255 | (targets test004.out.gen test004.err.gen) 256 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test004.out.gen -err test004.err.gen %{dep:test004.tig}))) 257 | 258 | (rule 259 | (alias runtest) 260 | (action (diff test004.out test004.out.gen))) 261 | 262 | (rule 263 | (alias runtest) 264 | (action (diff test004.err test004.err.gen))) 265 | 266 | (rule 267 | (targets test001.out.gen test001.err.gen) 268 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test001.out.gen -err test001.err.gen %{dep:test001.tig}))) 269 | 270 | (rule 271 | (alias runtest) 272 | (action (diff test001.out test001.out.gen))) 273 | 274 | (rule 275 | (alias runtest) 276 | (action (diff test001.err test001.err.gen))) 277 | 278 | (rule 279 | (targets test012.out.gen test012.err.gen) 280 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test012.out.gen -err test012.err.gen %{dep:test012.tig}))) 281 | 282 | (rule 283 | (alias runtest) 284 | (action (diff test012.out test012.out.gen))) 285 | 286 | (rule 287 | (alias runtest) 288 | (action (diff test012.err test012.err.gen))) 289 | 290 | (rule 291 | (targets test029.out.gen test029.err.gen) 292 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test029.out.gen -err test029.err.gen %{dep:test029.tig}))) 293 | 294 | (rule 295 | (alias runtest) 296 | (action (diff test029.out test029.out.gen))) 297 | 298 | (rule 299 | (alias runtest) 300 | (action (diff test029.err test029.err.gen))) 301 | 302 | (rule 303 | (targets test006.out.gen test006.err.gen) 304 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test006.out.gen -err test006.err.gen %{dep:test006.tig}))) 305 | 306 | (rule 307 | (alias runtest) 308 | (action (diff test006.out test006.out.gen))) 309 | 310 | (rule 311 | (alias runtest) 312 | (action (diff test006.err test006.err.gen))) 313 | 314 | (rule 315 | (targets test011.out.gen test011.err.gen) 316 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test011.out.gen -err test011.err.gen %{dep:test011.tig}))) 317 | 318 | (rule 319 | (alias runtest) 320 | (action (diff test011.out test011.out.gen))) 321 | 322 | (rule 323 | (alias runtest) 324 | (action (diff test011.err test011.err.gen))) 325 | 326 | (rule 327 | (targets test010.out.gen test010.err.gen) 328 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test010.out.gen -err test010.err.gen %{dep:test010.tig}))) 329 | 330 | (rule 331 | (alias runtest) 332 | (action (diff test010.out test010.out.gen))) 333 | 334 | (rule 335 | (alias runtest) 336 | (action (diff test010.err test010.err.gen))) 337 | 338 | (rule 339 | (targets test022.out.gen test022.err.gen) 340 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test022.out.gen -err test022.err.gen %{dep:test022.tig}))) 341 | 342 | (rule 343 | (alias runtest) 344 | (action (diff test022.out test022.out.gen))) 345 | 346 | (rule 347 | (alias runtest) 348 | (action (diff test022.err test022.err.gen))) 349 | 350 | (rule 351 | (targets test023.out.gen test023.err.gen) 352 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test023.out.gen -err test023.err.gen %{dep:test023.tig}))) 353 | 354 | (rule 355 | (alias runtest) 356 | (action (diff test023.out test023.out.gen))) 357 | 358 | (rule 359 | (alias runtest) 360 | (action (diff test023.err test023.err.gen))) 361 | 362 | (rule 363 | (targets test008.out.gen test008.err.gen) 364 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test008.out.gen -err test008.err.gen %{dep:test008.tig}))) 365 | 366 | (rule 367 | (alias runtest) 368 | (action (diff test008.out test008.out.gen))) 369 | 370 | (rule 371 | (alias runtest) 372 | (action (diff test008.err test008.err.gen))) 373 | 374 | (rule 375 | (targets test030.out.gen test030.err.gen) 376 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test030.out.gen -err test030.err.gen %{dep:test030.tig}))) 377 | 378 | (rule 379 | (alias runtest) 380 | (action (diff test030.out test030.out.gen))) 381 | 382 | (rule 383 | (alias runtest) 384 | (action (diff test030.err test030.err.gen))) 385 | 386 | (rule 387 | (targets test025.out.gen test025.err.gen) 388 | (action (run ../tools/run_test.exe -cmd %{dep:../src/main.exe} -runtime %{dep:../runtime/runtime.c} -out test025.out.gen -err test025.err.gen %{dep:test025.tig}))) 389 | 390 | (rule 391 | (alias runtest) 392 | (action (diff test025.out test025.out.gen))) 393 | 394 | (rule 395 | (alias runtest) 396 | (action (diff test025.err test025.err.gen))) 397 | -------------------------------------------------------------------------------- /src/typecheck.ml: -------------------------------------------------------------------------------- 1 | open Typing 2 | open Tabs 3 | 4 | let seq s1 s2 = 5 | match s1, s2 with 6 | | Sskip, s | s, Sskip -> s 7 | | _ -> Sseq (s1, s2) 8 | 9 | type value = 10 | | Var of {ty: type_id; id: Typing.ident; escapes: Ident.Set.t ref} 11 | | Fun of signature * implem 12 | 13 | module StringMap = Map.Make(String) 14 | 15 | type env = 16 | { 17 | escapes: Ident.Set.t ref; 18 | vars: (Typing.ident * type_id) list ref; 19 | funs: Typing.fundef list ref; 20 | cstr: (Typing.ident, type_structure) Hashtbl.t; 21 | venv: value StringMap.t; 22 | tenv: type_id StringMap.t; 23 | loop: bool; 24 | next_ident: Ident.state; 25 | } 26 | 27 | 28 | let base_tenv = 29 | [ 30 | "int", Tint; 31 | "string", Tstring; 32 | ] 33 | 34 | let base_venv = 35 | [ 36 | "printi", [Tint], None; 37 | "print", [Tstring], None; 38 | "flush", [], None; 39 | "not", [Tint], Some Tint; 40 | "exit", [Tint], None; 41 | (* "getchar", [], Some Tstring; 42 | "ord", [Tstring], Some Tint; 43 | "chr", [Tint], Some Tstring; 44 | "size", [Tstring], Some Tint; 45 | "substring", [Tstring; Tint; Tint], Some Tstring; 46 | "concat", [Tstring; Tstring], Some Tstring; *) 47 | ] 48 | 49 | let toplevel_env () = 50 | let venv = 51 | let f venv (name, args, res) = 52 | StringMap.add name (Fun ((args, res), External ("TIG_" ^ name))) venv in 53 | List.fold_left f StringMap.empty base_venv 54 | in 55 | { escapes = ref Ident.Set.empty; 56 | vars = ref []; 57 | funs = ref []; 58 | cstr = Hashtbl.create 0; 59 | venv; 60 | tenv = StringMap.of_list base_tenv; 61 | loop = false; 62 | next_ident = Ident.new_state () } 63 | 64 | type error = 65 | | Unbound_variable of string 66 | | Unknown_function of string 67 | | Unknown_type_name of string 68 | | Wrong_arity of int * int 69 | | Duplicate_type_name of string 70 | | Not_a_statement 71 | | Not_a_record of type_id 72 | | Not_an_array of type_id 73 | | Unknown_field of string * string 74 | | Illegal_nil 75 | | Illegal_break 76 | | Missing_value 77 | | Mismatched_field of string * string 78 | | Missing_fields of string * string list 79 | | Too_many_fields of string * string list 80 | 81 | let string_of_error = function 82 | | Unbound_variable s -> Printf.sprintf "unknown variable `%s'" s 83 | | Unknown_function s -> Printf.sprintf "unknown function `%s'" s 84 | | Unknown_type_name s -> Printf.sprintf "unknown type name `%s'" s 85 | | Wrong_arity (expected, actual) -> Printf.sprintf "wrong number of arguments: expected %i, got %i" expected actual 86 | | Duplicate_type_name s -> Printf.sprintf "repeated type name `%s'" s 87 | | Not_a_statement -> "this expression should not produce a value" 88 | | Not_a_record _ -> "this expression does not belong to a record type" 89 | | Not_an_array _ -> "this expression does not belong to an array type" 90 | | Unknown_field (ty, s) -> Printf.sprintf "record type `%s' does not contain a field `%s'" ty s 91 | | Illegal_nil -> Printf.sprintf "`nil' cannot appear here" 92 | | Illegal_break -> Printf.sprintf "`break' cannot appear here" 93 | | Missing_value -> Printf.sprintf "value-producing expression was expected here" 94 | | Mismatched_field (ty, s) -> Printf.sprintf "a field named `%s' belonging to the type `%s' was expected here" s ty 95 | | Missing_fields (ty, sl) -> 96 | Printf.sprintf "some fields belonging to the type `%s' are missing: %s" 97 | ty (String.concat ", " sl) 98 | | Too_many_fields (ty, sl) -> 99 | Printf.sprintf "too many fields for type `%s': %s" 100 | ty (String.concat ", " sl) 101 | 102 | exception Error of error loc 103 | 104 | let find_var env id = 105 | match StringMap.find_opt id.desc env.venv with 106 | | Some (Var {ty; id; escapes}) -> 107 | if escapes != env.escapes then escapes := Ident.Set.add id !escapes; 108 | ty, id 109 | | Some (Fun _) | None -> raise (Error {id with desc = Unbound_variable id.desc}) 110 | 111 | let find_fun env id = 112 | match StringMap.find_opt id.desc env.venv with 113 | | Some (Fun (sg, impl)) -> sg, impl 114 | | Some (Var _) | None -> raise (Error {id with desc = Unknown_function id.desc}) 115 | 116 | let find_type env id = 117 | match StringMap.find_opt id.desc env.tenv with 118 | | Some tid -> tid 119 | | None -> raise (Error {id with desc = Unknown_type_name id.desc}) 120 | 121 | let get_record_type env loc = function 122 | | Tconstr tid as ty -> 123 | begin match Hashtbl.find env.cstr tid with 124 | | Trecord fields -> tid, fields 125 | | Tarray _ -> raise (Error {loc; desc = Not_a_record ty}) 126 | end 127 | | ty -> 128 | raise (Error {loc; desc = Not_a_record ty}) 129 | 130 | let get_array_type env loc = function 131 | | Tconstr tid as ty -> 132 | begin match Hashtbl.find env.cstr tid with 133 | | Tarray tid -> tid 134 | | Trecord _ -> raise (Error {loc; desc = Not_an_array ty}) 135 | end 136 | | ty -> 137 | raise (Error {loc; desc = Not_an_array ty}) 138 | 139 | let add_var env (x : ident) tid = 140 | let id = Ident.create env.next_ident x.desc in 141 | env.vars := (id, tid) :: !(env.vars); 142 | {desc = Typing.Vsimple id; ty = tid}, 143 | {env with venv = StringMap.add x.desc (Var {ty = tid; id; escapes = env.escapes}) env.venv} 144 | 145 | let add_fresh_var env tid = 146 | let id = Ident.create env.next_ident "tmp" in 147 | env.vars := (id, tid) :: !(env.vars); 148 | {ty = tid; desc = Typing.Vsimple id} 149 | 150 | let has_duplicate (type a) (f : a -> 'b) (l : a list) = 151 | let exception Found of a in 152 | let h = Hashtbl.create 0 in 153 | match 154 | List.iter (fun x -> 155 | let y = f x in 156 | match Hashtbl.find_opt h y with Some () -> raise (Found x) | None -> Hashtbl.add h y () 157 | ) l 158 | with 159 | | () -> None 160 | | exception Found x -> Some x 161 | 162 | let check_unique_type_name xts = 163 | match has_duplicate (fun (x, _) -> x.desc) xts with 164 | | None -> () 165 | | Some (x, _) -> raise (Error {x with desc = Duplicate_type_name x.desc}) 166 | 167 | let add_types env xts = 168 | check_unique_type_name xts; 169 | let constrs, xts' = 170 | List.fold_left (fun (constrs, xts) (name, ty) -> 171 | match ty with 172 | | Tname s -> 173 | constrs, (name, `Tname s) :: xts 174 | | Tarray ty -> 175 | let constr = Ident.create env.next_ident name.desc in 176 | StringMap.add name.desc (Tconstr constr) constrs, 177 | (name, `Tarray (constr, ty)) :: xts 178 | | Trecord fl -> 179 | let constr = Ident.create env.next_ident name.desc in 180 | StringMap.add name.desc (Tconstr constr) constrs, 181 | (name, `Trecord (constr, fl)) :: xts 182 | ) (StringMap.empty, []) xts 183 | in 184 | let xts' = List.rev xts' in 185 | let resolve name = 186 | let visited = Hashtbl.create 0 in 187 | let rec loop name = 188 | if Hashtbl.mem visited name then failwith "recursive loop"; 189 | Hashtbl.add visited name (); 190 | match List.find_map (fun (x, ty) -> if x.desc = name then Some ty else None) xts with 191 | | None -> 192 | begin match StringMap.find_opt name env.tenv with 193 | | None -> failwith "type not found" 194 | | Some tid -> tid 195 | end 196 | | Some (Tarray _ | Trecord _) -> 197 | StringMap.find name constrs 198 | | Some Tname s -> 199 | loop s.desc 200 | in 201 | loop name 202 | in 203 | let f = function 204 | | `Tarray (constr, elt) -> 205 | Hashtbl.replace env.cstr constr (Tarray (resolve elt.desc)); 206 | Tconstr constr 207 | | `Trecord (constr, fields) -> 208 | let fields = List.map (fun (x, ty) -> x.desc, resolve ty.desc) fields in 209 | Hashtbl.replace env.cstr constr (Trecord fields); 210 | Tconstr constr 211 | | `Tname s -> 212 | resolve s.desc 213 | in 214 | let tenv = 215 | List.fold_left (fun tenv (name, desc) -> 216 | StringMap.add name.desc (f desc) tenv 217 | ) env.tenv xts' 218 | in 219 | {env with tenv} 220 | 221 | let loc_of_variable v = 222 | { 223 | filename = v.loc.pos_fname; 224 | lineno = v.loc.pos_lnum; 225 | column = v.loc.pos_cnum - v.loc.pos_bol + 1; 226 | } 227 | 228 | let rec statement env e = 229 | let s, e' = expression env e in 230 | match e' with 231 | | None -> s 232 | | Some _ -> raise (Error {e with desc = Not_a_statement}) 233 | 234 | and variable env v : statement * variable = 235 | match v.desc with 236 | | Vsimple x -> 237 | let tid, id = find_var env x in 238 | Sskip, {desc = Vsimple id; ty = tid} 239 | | Vsubscript (v, x) -> 240 | let s1, v' = variable env v in 241 | let t' = get_array_type env v.loc v'.ty in 242 | let s2, x' = expression' env x Tint in 243 | let loc = loc_of_variable x in 244 | seq s1 s2, {desc = Vsubscript (loc, v', x'); ty = t'} 245 | | Vfield (v, x) -> 246 | let s, v' = variable env v in 247 | let cstr, xts = get_record_type env v.loc v'.ty in 248 | let i, tx = 249 | let rec loop i = function 250 | | [] -> raise (Error {x with desc = Unknown_field (Ident.name cstr, x.desc)}) 251 | | (x', t') :: _xs when x' = x.desc -> i, t' 252 | | _ :: xs -> loop (i+1) xs 253 | in 254 | loop 0 xts 255 | in 256 | let loc = loc_of_variable v in 257 | s, {desc = Vfield (loc, v', i); ty = tx} 258 | 259 | and declarations env ds : statement * env = 260 | match ds with 261 | | [] -> Sskip, env 262 | | Dvar (x, xty, init) :: ds -> 263 | let sinit, einit = 264 | match xty with 265 | | None -> expression'' env init 266 | | Some sty -> 267 | let ty = find_type env sty in 268 | let s, e = expression' env init ty in 269 | s, e 270 | in 271 | let var, env = add_var env x einit.ty in 272 | let s', env = declarations env ds in 273 | seq sinit (seq (Sassign (var, einit)) s'), env 274 | | Dtype (s, ty) :: ds -> 275 | let rec loop accu = function 276 | | [] -> List.rev accu, [] 277 | | Dtype (s, ty) :: ds -> loop ((s, ty) :: accu) ds 278 | | (Dvar _ | Dfun _) :: _ as ds -> List.rev accu, ds 279 | in 280 | let tys, ds = loop [s, ty] ds in 281 | declarations (add_types env tys) ds 282 | | Dfun fdef :: ds -> 283 | let rec loop accu = function 284 | | [] -> List.rev accu, [] 285 | | Dfun fdef :: ds -> loop (fdef :: accu) ds 286 | | (Dvar _ | Dtype _) :: _ as ds -> List.rev accu, ds 287 | in 288 | let fdefs, ds = loop [fdef] ds in 289 | declarations (add_functions env fdefs) ds 290 | 291 | and expression' env e (ty : type_id) : statement * expression = 292 | match e.desc with 293 | | Enil -> 294 | let _ = get_record_type env e.loc ty in 295 | Sskip, {desc = Enil; ty} 296 | | Eseq el -> 297 | let rec loop = function 298 | | [] -> 299 | raise (Error {e with desc = Missing_value}) 300 | | [e] -> 301 | expression' env e ty 302 | | e :: el -> 303 | let s1, _ = expression env e in 304 | let s2, e2 = loop el in 305 | seq s1 s2, e2 306 | in 307 | loop el 308 | | Eif (e1, e2, Some e3) -> 309 | let s1, e1 = expression' env e1 Tint in 310 | let s2, e2 = expression' env e2 ty in 311 | let s3, e3 = expression' env e3 ty in 312 | let v = add_fresh_var env ty in 313 | seq s1 (Sifthenelse (e1, seq s2 (Sassign (v, e2)), seq s3 (Sassign (v, e3)))), {ty; desc = Evar v} 314 | | Elet (ds, e) -> 315 | let s1, env = declarations env ds in 316 | let s2, e = expression' env e ty in 317 | seq s1 s2, e 318 | | _ -> 319 | let s, e' = expression env e in 320 | match e' with 321 | | None -> raise (Error {e with desc = Missing_value}) 322 | | Some e' -> 323 | let ok = 324 | match ty, e'.ty with 325 | | Tint, Tint | Tstring, Tstring -> true 326 | | Tconstr cstr1, Tconstr cstr2 -> Ident.equal cstr1 cstr2 327 | | _ -> false 328 | in 329 | if not ok then failwith "type error"; 330 | s, e' 331 | 332 | and expression'' env e : statement * expression = 333 | match expression env e with 334 | | s, Some e -> s, e 335 | | _, None -> raise (Error {e with desc = Missing_value}) 336 | 337 | and expression env e : statement * expression option = 338 | match e.desc with 339 | | Eint n -> 340 | Sskip, Some {ty = Tint; desc = Eint n} 341 | | Estring s -> 342 | Sskip, Some {ty = Tstring; desc = Estring s} 343 | | Enil -> 344 | raise (Error {e with desc = Illegal_nil}) 345 | | Evar v -> 346 | let s, v = variable env v in 347 | s, Some {ty = v.ty; desc = Evar v} 348 | | Ebinop (e1, Op_add, e2) -> 349 | let s1, e1 = expression' env e1 Tint in 350 | let s2, e2 = expression' env e2 Tint in 351 | seq s1 s2, Some {ty = Tint; desc = Ebinop (e1, Op_add, e2)} 352 | | Ebinop (e1, Op_sub, e2) -> 353 | let s1, e1 = expression' env e1 Tint in 354 | let s2, e2 = expression' env e2 Tint in 355 | seq s1 s2, Some {ty = Tint; desc = Ebinop (e1, Op_sub, e2)} 356 | | Ebinop (e1, Op_mul, e2) -> 357 | let s1, e1 = expression' env e1 Tint in 358 | let s2, e2 = expression' env e2 Tint in 359 | seq s1 s2, Some {ty = Tint; desc = Ebinop (e1, Op_mul, e2)} 360 | | Ebinop (e1, Op_div, e2) -> 361 | let s1, e1 = expression' env e1 Tint in 362 | let s2, e2 = expression' env e2 Tint in 363 | seq s1 s2, Some {ty = Tint; desc = Ebinop (e1, Op_div, e2)} 364 | | Ebinop (e1, Op_cmp c, e2) -> 365 | let s1, e1 = expression' env e1 Tint in 366 | let s2, e2 = expression' env e2 Tint in 367 | seq s1 s2, Some {ty = Tint; desc = Ebinop (e1, Op_cmp c, e2)} 368 | | Eassign (v, e) -> 369 | let s1, v = variable env v in 370 | let s2, e = expression' env e v.ty in 371 | seq s1 (seq s2 (Sassign (v, e))), None 372 | | Ecall (fn, params) -> 373 | let args, res as sg, impl = find_fun env fn in 374 | let num_expected = List.length args in 375 | let num_actual = List.length params in 376 | if num_expected <> num_actual then raise (Error {fn with desc = Wrong_arity (num_expected, num_actual)}); 377 | let s, params = 378 | List.fold_left2 (fun (s, el) arg param -> let s', e' = expression' env param arg in seq s s', e' :: el) 379 | (Sskip, []) args params 380 | in 381 | let v = Option.map (add_fresh_var env) res in 382 | let s', e' = 383 | Scall (v, impl, List.rev params, sg), 384 | match v with None -> None | Some v -> Some {ty = v.ty; desc = Typing.Evar v} 385 | in 386 | seq s s', e' 387 | | Eseq el -> 388 | List.fold_left (fun (s, _) e -> 389 | let s', e = expression env e in 390 | seq s s', e 391 | ) (Sskip, None) el 392 | | Earray (ty, e1, e2) -> 393 | let ty = find_type env ty in 394 | let elty = get_array_type env e.loc ty in 395 | let s1, size = expression' env e1 Tint in 396 | let s2, init = expression' env e2 elty in 397 | let v = add_fresh_var env ty in 398 | seq s1 (seq s2 (Sarray (v, size, init))), Some {ty; desc = Evar v} 399 | | Erecord (ty, fl) -> 400 | let ty = find_type env ty in 401 | let cstr, ftyl = get_record_type env e.loc ty in 402 | let rec loop (s, el) fl tyl = 403 | match fl, tyl with 404 | | [], [] -> 405 | s, List.rev el 406 | | (sname, f) :: fl, (name, ty) :: tyl -> 407 | if not (String.equal sname.desc name) then 408 | raise (Error {sname with desc = Mismatched_field (Ident.name cstr, name)}); 409 | let s', e = expression' env f ty in 410 | loop (seq s s', e :: el) fl tyl 411 | | [], _ :: _ -> 412 | raise (Error {e with desc = Missing_fields (Ident.name cstr, List.map fst tyl)}) 413 | | _ :: _, [] -> 414 | raise (Error {e with desc = Too_many_fields (Ident.name cstr, List.map (fun (x, _) -> x.desc) fl)}) 415 | in 416 | let s, tfl = loop (Sskip, []) fl ftyl in 417 | let v = add_fresh_var env ty in 418 | seq s (Srecord (v, tfl)), Some {ty; desc = Evar v} 419 | | Eif (e1, e2, e3) -> 420 | let s1, e1 = expression' env e1 Tint in 421 | let s2, e2' = expression env e2 in 422 | let s, e = 423 | match e2', e3 with 424 | | Some _, None -> 425 | raise (Error {e2 with desc = Not_a_statement}) 426 | | None, None -> 427 | Sifthenelse (e1, s2, Sskip), None 428 | | None, Some e3 -> 429 | Sifthenelse (e1, s2, statement env e3), None 430 | | Some e2, Some e3 -> 431 | let s3, e3 = expression' env e3 e2.ty in 432 | let v = add_fresh_var env e2.ty in 433 | Sifthenelse (e1, seq s2 (Sassign (v, e2)), seq s3 (Sassign (v, e3))), 434 | Some {ty = e2.ty; desc = Typing.Evar v} 435 | in 436 | seq s1 s, e 437 | | Ewhile (e1, e2) -> 438 | let s1, e1 = expression' env e1 Tint in 439 | let s2 = statement {env with loop = true} e2 in 440 | seq s1 (Sloop (seq s1 (Sifthenelse (e1, s2, Sbreak)))), None 441 | | Efor (i, e1, e2, e3) -> 442 | let s1, e1 = expression' env e1 Tint in 443 | let s2, e2 = expression' env e2 Tint in 444 | let i, env = add_var env i Tint in 445 | let s3 = statement {env with loop = true} e3 in 446 | let loop = 447 | Sloop (Sifthenelse 448 | ({ty = Tint; desc = Ebinop(e2, Op_cmp Clt, {ty = Tint; desc = Evar i})}, 449 | Sbreak, seq s3 (Sassign (i, {ty = Tint; desc = Ebinop ({ty = Tint; desc = Evar i}, 450 | Op_add, {ty = Tint; desc = Eint 1L})})))) 451 | in 452 | seq s1 (seq s2 (seq (Sassign (i, e1)) loop)), None 453 | | Ebreak -> 454 | if not env.loop then raise (Error {e with desc = Illegal_break}); 455 | Sbreak, None 456 | | Elet (ds, e) -> 457 | let s1, env = declarations env ds in 458 | let s2, e = expression env e in 459 | seq s1 s2, e 460 | 461 | and add_functions env fdefs = 462 | let names, venv = 463 | List.fold_left (fun (names, venv) fdef -> 464 | let fn_name = Ident.create env.next_ident fdef.fn_name.desc in 465 | let rtyp = Option.map (find_type env) fdef.fn_rtyp in 466 | let args = List.map (fun (_name, sty) -> find_type env sty) fdef.fn_args in 467 | let sg = args, rtyp in 468 | (Internal fn_name, args, rtyp) :: names, 469 | StringMap.add fdef.fn_name.desc (Fun (sg, Internal fn_name)) venv 470 | ) ([], env.venv) fdefs 471 | in 472 | List.iter2 (fun (fn_name, fn_args, fn_rtyp) fdef -> 473 | let escapes = ref Ident.Set.empty in 474 | let (fn_args, venv) = 475 | List.fold_left2 (fun (args, venv) (name, _) ty -> 476 | let id = Ident.create env.next_ident name.desc in 477 | (id, ty) :: args, StringMap.add name.desc (Var {ty; id; escapes}) venv 478 | ) ([], venv) fdef.fn_args fn_args 479 | in 480 | let vars = ref [] in 481 | let env = {env with vars; venv; escapes} in 482 | let fn_body = 483 | match fn_rtyp with 484 | | None -> 485 | statement env fdef.fn_body 486 | | Some ty -> 487 | let s, e = expression' env fdef.fn_body ty in 488 | seq s (Sreturn (Some e)) 489 | in 490 | let fdef = {fn_name; fn_rtyp; fn_args; fn_vars = !vars; fn_esca = !escapes; fn_body} in 491 | env.funs := fdef :: !(env.funs) 492 | ) (List.rev names) fdefs; 493 | {env with venv} 494 | 495 | let program (p : Tabs.program) = 496 | let env = toplevel_env () in 497 | let body = statement env p.body in 498 | let funs = 499 | {fn_name = Main; fn_rtyp = None; fn_args = []; fn_vars = !(env.vars); fn_esca = !(env.escapes); fn_body = body} :: 500 | !(env.funs) 501 | in 502 | let cstr = Hashtbl.fold (fun id ts accu -> (id, ts) :: accu) env.cstr [] in 503 | {cstr; funs} 504 | --------------------------------------------------------------------------------