├── .cvsignore ├── .gitignore ├── ExnTests ├── complex.mlpr ├── curry.mlpr ├── curryfun-good.mlpr ├── data.mlpr ├── fun.mlpr ├── ho.mlpr ├── partialapp-bad.mlpr ├── partialapp-good.mlpr ├── partialapp2-good.mlpr ├── plain-good.mlpr ├── simple.mlpr └── simplefun-good.mlpr ├── Makefile ├── README.md ├── Tests ├── .cvsignore ├── ackermann.mlpr ├── alloc.mlpr ├── assoc.mlpr ├── astest.mlpr ├── bad-expr.mlpr ├── blackhole.mlpr ├── catchall.mlpr ├── catchall2.mlpr ├── catchall3.mlpr ├── const.mlpr ├── const2.mlpr ├── cps-better.mlpr ├── cps-convert-cc.mlpr ├── cps-convert-cc2-wc.mlpr ├── cps-convert-cc2.mlpr ├── cps-convert.mlpr ├── cps-convert1.sml ├── cps-convert2.sml ├── cps-convert3.sml ├── cps-convert4.sml ├── cps-improved.mlpr ├── cps-naive.mlpr ├── cps-withcases.mlpr ├── div.mlpr ├── echo.mlpr ├── evenodd.mlpr ├── exn-a-or-b.mlpr ├── exnabc.mlpr ├── expr.mlpr ├── ext-rs.mlpr ├── flat.mlpr ├── foo.mlpr ├── funupdate.mlpr ├── interp.mlpr ├── lastcons.mlpr ├── loop.mlpr ├── mergesort.mlpr ├── mergesort2.mlpr ├── mergesort3.mlpr ├── mod.mlpr ├── mono-capture.mlpr ├── mono-extend.mlpr ├── mono-replace.mlpr ├── nat.mlpr ├── neg.mlpr ├── neg2.mlpr ├── person.mlpr ├── poly-capture.mlpr ├── poly-extend.mlpr ├── poly-replace.mlpr ├── polyr.mlpr ├── pr.mlpr ├── reverse.mlpr ├── scratch.mlpr ├── simpleexn.mlpr ├── singleton.mlpr ├── spill.mlpr ├── tcall.mlpr ├── twosel.mlpr └── typcall.mlpr ├── Tests2 ├── bad-expr.mlpr ├── ex_pat.mlpr ├── ex_pat_simple.mlpr ├── ex_sub.mlpr ├── ex_where.mlpr ├── ex_where_simple.mlpr ├── ex_with.mlpr ├── ex_with_simple_1.mlpr ├── ex_with_simple_2.mlpr ├── recsub.mlpr ├── run.sh ├── simple.mlpr ├── test_pattern_with_case.mlpr ├── test_pattern_with_let.mlpr ├── test_pattern_with_pri.mlpr ├── test_pattern_with_pri_simple.mlpr └── test_pattern_with_wild.mlpr ├── absyn.sml ├── anf-interpreter.sml ├── anf-opt.sml ├── anf.sml ├── asm.sml ├── ast.sml ├── baseenv.sml ├── bbtree.sml ├── cg.sml ├── closed.sml ├── closure.sml ├── color.sml ├── compile.sml ├── doc ├── .cvsignore ├── langspec.pdf └── langspec.tex ├── elaborate.sml ├── env.sml ├── extacc.sml ├── fclusters.sml ├── flatten.sml ├── flowgraph.sml ├── frame.sml ├── graph.sig ├── graph.sml ├── interp.sml ├── label.sml ├── lambda-interpreter.sml ├── lambda.sml ├── lambda2anf.sml ├── litdata.sml ├── liveness.sml ├── lvar.sml ├── machspec.sml ├── main.sml ├── makegraph.sml ├── mlpolyr.cm ├── mlpolyr.grm ├── mlpolyr.lex ├── mlpolyrc ├── notyet.sml ├── oper.sml ├── parse.sml ├── pranf.sml ├── prbbtree.sml ├── prfclusters.sml ├── purity.sml ├── ra.sml ├── reclab.sml ├── rewrite.sml ├── rt ├── Makefile ├── mlpr-rt-nogc.c └── mlpr-rt.c ├── symbol.sml ├── traceschedule.sml ├── tracetree.sml ├── translate.sml ├── treeify.sml ├── treeops.sml ├── tvar.sml ├── types.sml ├── typesutil.sml ├── uncurry.sml ├── unify.sml ├── util └── serv.sml └── value-numbering.sml /.cvsignore: -------------------------------------------------------------------------------- 1 | *.grm.sig 2 | *.grm.sml 3 | *.grm.desc 4 | *.lex.sml 5 | .cm 6 | .DS_Store 7 | *.ppc-darwin 8 | *.x86-unix 9 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Editor config directories 2 | .cm 3 | .idea 4 | .vscode 5 | .vs 6 | 7 | # Generated 8 | mlpolyr.grm.desc 9 | mlpolyr.grm.sig 10 | mlpolyr.grm.sml 11 | mlpolyr.lex.sml 12 | mlpolyr.x86-linux 13 | 14 | # Binaries 15 | *.o 16 | *.exe 17 | *.dll 18 | *.so 19 | *.dylib 20 | -------------------------------------------------------------------------------- /ExnTests/complex.mlpr: -------------------------------------------------------------------------------- 1 | let fun g x = if x < 0 then raise `A (`B 12) else 0 2 | fun f x = try r = g (x+1) in r handling `A x => raise x end 3 | in try r = f 0 4 | in r 5 | handling `B i => i 6 | end 7 | end 8 | -------------------------------------------------------------------------------- /ExnTests/curry.mlpr: -------------------------------------------------------------------------------- 1 | let fun apply f x = f x 2 | fun g x = if x < 0 then x else raise `A 10 3 | val g' = apply g 4 | fun f b = 5 | try r = if b then 0 else g' 22 6 | in r 7 | handling `A i => i+1 8 | end 9 | in f true + f false 10 | end 11 | -------------------------------------------------------------------------------- /ExnTests/curryfun-good.mlpr: -------------------------------------------------------------------------------- 1 | let fun f s t = 2 | if String.compare (s, t) == 0 then 3 | raise `Fail () 4 | else String.output "good!\n" 5 | in try () = f "!\n" (String.inputLine ()) 6 | in 0 7 | handling `Fail () => (String.output "too bad...\n"; 1) 8 | end 9 | end 10 | -------------------------------------------------------------------------------- /ExnTests/data.mlpr: -------------------------------------------------------------------------------- 1 | let fun g l = 2 | case l of [] => 0 3 | | (h,x)::t => if h<0 then raise x else g t 4 | 5 | fun f () = 6 | try r = g [(1,`A()),(2,`B 5),(3,`C true)] 7 | in r 8 | handling `A () => 0 9 | | `B i => i+1 10 | | `C b => if b then 0 else 1 11 | end 12 | in f () 13 | end 14 | -------------------------------------------------------------------------------- /ExnTests/fun.mlpr: -------------------------------------------------------------------------------- 1 | let fun g x = if x < 0 then x else raise `A 10 2 | fun f b = 3 | try r = if b then 0 else g 22 4 | in r 5 | handling `A i => i+1 6 | end 7 | in f true + f false 8 | end 9 | -------------------------------------------------------------------------------- /ExnTests/ho.mlpr: -------------------------------------------------------------------------------- 1 | let fun apply f x = f x 2 | fun g x = if x < 0 then x else raise `A 10 3 | fun f b = 4 | try r = if b then 0 else apply g 22 5 | in r 6 | handling `A i => i+1 7 | end 8 | in f true + f false 9 | end 10 | -------------------------------------------------------------------------------- /ExnTests/partialapp-bad.mlpr: -------------------------------------------------------------------------------- 1 | let fun app f = 2 | let val _ = String.output "app first stage\n" 3 | fun app' l = 4 | case l of [] => () 5 | | h :: t => (f h; app f t) 6 | in app' 7 | end 8 | fun f i = if i < 0 then raise `Negative () else () 9 | (* val f' = app f *) 10 | in try _ = app f [1, 2, 0, -1, 3] 11 | in 0 12 | handling `Negative () => (String.output "too bad...\n"; 1) 13 | end 14 | end 15 | -------------------------------------------------------------------------------- /ExnTests/partialapp-good.mlpr: -------------------------------------------------------------------------------- 1 | let fun f s t = 2 | if String.compare (s, t) == 0 then 3 | raise `Fail () 4 | else String.output "good!\n" 5 | val f' = f "!\n" 6 | in try () = f' (String.inputLine ()) 7 | in 0 8 | handling `Fail () => (String.output "too bad...\n"; 1) 9 | end 10 | end 11 | -------------------------------------------------------------------------------- /ExnTests/partialapp2-good.mlpr: -------------------------------------------------------------------------------- 1 | let fun app f l = 2 | case l of [] => () 3 | | h :: t => (f h; app f t) 4 | fun f i = if i < 0 then raise `Negative () else () 5 | val f' = app f 6 | in try _ = f' [1, 2, 0, -1, 3] 7 | in 0 8 | handling `Negative () => (String.output "too bad...\n"; 1) 9 | end 10 | end 11 | -------------------------------------------------------------------------------- /ExnTests/plain-good.mlpr: -------------------------------------------------------------------------------- 1 | try _ = if String.compare (String.inputLine (), "!\n") == 0 then 2 | raise `Fail () 3 | else String.output "good!\n" 4 | in 0 5 | handling `Fail () => (String.output "too bad...\n"; 1) 6 | end 7 | -------------------------------------------------------------------------------- /ExnTests/simple.mlpr: -------------------------------------------------------------------------------- 1 | let fun f b = 2 | try r = if b then 0 else raise `A 10 3 | in r 4 | handling `A i => i+1 5 | end 6 | in f true + f false 7 | end 8 | -------------------------------------------------------------------------------- /ExnTests/simplefun-good.mlpr: -------------------------------------------------------------------------------- 1 | let fun f s = 2 | if String.compare (s, "!\n") == 0 then 3 | raise `Fail () 4 | else String.output "good!\n" 5 | in try () = f (String.inputLine ()) 6 | in 0 7 | handling `Fail () => (String.output "too bad...\n"; 1) 8 | end 9 | end 10 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: compiler 2 | @echo all done 3 | 4 | runtime: 5 | (cd rt; $(MAKE); cd ..) 6 | 7 | compiler: 8 | ml-build mlpolyr.cm Main.main mlpolyr 9 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # MLPolyR 2 | 3 | This is a ML dialect with first-class cases (first-class pattern matching) and row-polymorphism 4 | that solves the expression problem directly with language features. 5 | 6 | ## Build 7 | 8 | Install SML/NJ, tested with v110.75 and v110.87 on Linux (make sure it has ML-lex) 9 | and build with this command: 10 | 11 | ``` 12 | make 13 | ``` 14 | 15 | and that's it. 16 | 17 | ## Usage 18 | 19 | There's a LaTeXed PDF manual is in `doc/`, which is excatly the same as [language spec][spec]. 20 | 21 | There are also a [compiler overview][c--], a [paper][fc-c], and a [PhD thesis][tse] about MLPolyR. 22 | 23 | [spec]: https://people.cs.uchicago.edu/~blume/classes/spr2005/cmsc22620/docs/langspec.pdf 24 | [c--]: http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.210.2810&rep=rep1&type=pdf 25 | [tse]: https://arxiv.org/abs/0910.2654 26 | [fc-c]: https://people.cs.uchicago.edu/~blume/papers/icfp06.pdf 27 | 28 | For code editing, we've created an [IntelliJ plugin][ij-p] for MLPolyR. 29 | 30 | [ij-p]: https://github.com/owo-lang/intellij-dtlc 31 | 32 | ## Current Status 33 | 34 | It builds and produce PPC assembly code, which cause failure upon linking phase. 35 | 36 | Call `mlpolyrc` with command line switch `-S` emits assembly code without linking, which is a viable option if you 37 | only want typechecking programs. Other switches all requires linking. 38 | 39 | Now you can call with `-t` to typecheck without doing codegen. 40 | 41 | Now you use `-e` to eval. However, I/O operation is not yet supported, which means 42 | all you can do is integer arith stuff. 43 | -------------------------------------------------------------------------------- /Tests/.cvsignore: -------------------------------------------------------------------------------- 1 | *.s 2 | *.o 3 | -------------------------------------------------------------------------------- /Tests/ackermann.mlpr: -------------------------------------------------------------------------------- 1 | let fun ack (m, n) = 2 | if m == 0 then n + 1 3 | (* else if m == 1 then n + 2 *) 4 | else if n == 0 then ack (m - 1, 1) 5 | else ack (m - 1, ack (m, n - 1)) 6 | 7 | fun loop l = 8 | case l of 9 | [] => 0 10 | | h :: t => 11 | (String.output (String.concat 12 | ["ack(3,", h, ")=", 13 | String.fromInt (ack (3, String.toInt h)), 14 | "\n"]); 15 | loop t) 16 | 17 | in loop String.cmdline_args 18 | end 19 | -------------------------------------------------------------------------------- /Tests/alloc.mlpr: -------------------------------------------------------------------------------- 1 | let fun append (x, y) = 2 | case x of 3 | [] => y 4 | | h :: t => append (t, h :: y) 5 | 6 | fun copy l = append (l, []) 7 | 8 | fun grow (n, l) = 9 | if n <= 0 then l 10 | else let val l' = copy l 11 | in grow (n-1, append (l', l')) 12 | end 13 | 14 | fun keep_copying l = 15 | (String.output "*"; keep_copying (copy l)) 16 | 17 | fun ignore _ = () 18 | 19 | fun grow1 n = grow (n, [1]) 20 | 21 | fun loop l = 22 | case l of 23 | [] => 0 24 | | h :: t => (String.output h; 25 | String.output "...\n"; 26 | ignore (keep_copying (grow1 (String.toInt h))); 27 | loop t) 28 | in loop String.cmdline_args 29 | end 30 | -------------------------------------------------------------------------------- /Tests/assoc.mlpr: -------------------------------------------------------------------------------- 1 | let fun straighten e = 2 | let fun build (wl, e) = 3 | case wl of 4 | [] => e 5 | | h :: t => 6 | match h with 7 | cases `Num i => build (t, `Plus (`Num i, e)) 8 | | `Plus (x, y) => build (y :: x :: t, e) 9 | fun start (e, wl) = 10 | match e with 11 | cases `Num i => build (wl, `Num i) 12 | | `Plus (x, y) => start (y, x :: wl) 13 | in start (e, []) 14 | end 15 | 16 | fun count e = 17 | let fun isnum e = match e with cases `Num _ => 1 18 | in match e with 19 | cases `Num i => 1 20 | | `Plus (n, e) => isnum n + count e 21 | end 22 | 23 | fun foo e = count (straighten e) 24 | in 0 25 | end 26 | -------------------------------------------------------------------------------- /Tests/astest.mlpr: -------------------------------------------------------------------------------- 1 | let fun f (r as { a, b, ... = rest }) = 2 | if a > 0 then r 3 | else { a = 10, b = "foo", ... = rest } 4 | fun show { a, b, c, ... } = String.output (String.concat [b, "\n"]) 5 | in show (f { a = 0, b = "test1", c = 22 }); 6 | show (f { a = 1, b = "test2", c = 33, d = 4 }); 7 | 0 8 | end 9 | -------------------------------------------------------------------------------- /Tests/bad-expr.mlpr: -------------------------------------------------------------------------------- 1 | let fun mkEval (c, e) = match e with c 2 | 3 | val _ = mkEval (cases `Var v => 0, `Var 0) 4 | in 5 | 0 6 | end 7 | -------------------------------------------------------------------------------- /Tests/blackhole.mlpr: -------------------------------------------------------------------------------- 1 | let fun mkConvert (c, e) = 2 | let fun cvt e = match e with cc 3 | with cases cc = c cvt 4 | in cvt e 5 | end 6 | fun ignore x = () 7 | in 8 | ignore (mkConvert (fn cvt => (ignore (cvt (`A ())); cases `A () => "A"), `A ())); 9 | 0 10 | end 11 | 12 | -------------------------------------------------------------------------------- /Tests/catchall.mlpr: -------------------------------------------------------------------------------- 1 | let fun f () = 2 | if String.compare (String.inputLine (), "!\n") == 0 then 3 | raise `Exn () 4 | else String.output "hello, world!\n" 5 | fun g () = 6 | (try _ = f () 7 | in String.output "It's a success!! :-)\n" 8 | handling _ => String.output "Bummer! :-(\n" 9 | end; 10 | String.output "done\n"; 11 | 0) 12 | val r = g () 13 | in String.output "good bye\n"; 14 | r 15 | end 16 | -------------------------------------------------------------------------------- /Tests/catchall2.mlpr: -------------------------------------------------------------------------------- 1 | let fun ignore _ = () 2 | fun f () = 3 | let val l = String.inputLine () 4 | in if String.compare (l, "!\n") == 0 then 5 | raise `Exn () 6 | else if String.compare (l, ".\n") == 0 then 7 | (String.output "done\n"; 0) 8 | else (String.output "hello, world!\n"; ignore (f ()); 9 | String.output ":-)\n"; 0) 10 | end 11 | in try r = f () 12 | in (String.output "It's a success!! :-)\n"; r) 13 | handling _ => (String.output "Bummer! :-(\n"; 1) 14 | end 15 | end 16 | -------------------------------------------------------------------------------- /Tests/catchall3.mlpr: -------------------------------------------------------------------------------- 1 | let fun ignore _ = () 2 | fun f () = 3 | let val l = String.inputLine () 4 | in if String.compare (l, "") == 0 then 5 | (String.output "EOF\n"; 0) 6 | else if String.compare (l, "!\n") == 0 then 7 | raise `Exn () 8 | else if String.compare (l, ".\n") == 0 then 9 | (String.output "done\n"; 0) 10 | else (String.output "hello, world!\n"; ignore (f ()); 11 | String.output ":-)\n"; 0) 12 | end 13 | fun g () = 14 | try r = f () 15 | in (String.output "It's a success!! :-)\n"; r) 16 | handling _ => (String.output "Bummer! :-(\n"; g ()) 17 | end 18 | in g() 19 | end 20 | -------------------------------------------------------------------------------- /Tests/const.mlpr: -------------------------------------------------------------------------------- 1 | let fun m_nothing ev = nocases 2 | 3 | fun m_const m_other ev = 4 | cases `Const i => i 5 | default: m_other ev 6 | 7 | fun m_plus m_other ev = 8 | cases `Plus (x, y) => ev x + ev y 9 | default: m_other ev 10 | 11 | fun m_minus m_other ev = 12 | cases `Minus (x, y) => ev x - ev y 13 | default: m_other ev 14 | 15 | fun ev_constplus e = 16 | match e with m_plus (m_const m_nothing) ev_constplus 17 | 18 | fun ev_constplusminus e = 19 | match e with m_minus (m_plus (m_const m_nothing)) ev_constplusminus 20 | 21 | fun ev_constminus e = 22 | match e with m_minus (m_const m_nothing) ev_constminus 23 | 24 | val e0 = `Plus (`Const 1, `Plus (`Const 2, `Const 3)) 25 | val e1 = `Minus (e0, `Const 3) 26 | 27 | fun test (n, f) = 28 | String.output (String.concat [n, ": ", String.fromInt (f ()), "\n"]) 29 | 30 | fun foo r = (r.a, r) 31 | 32 | fun tcp0 () = ev_constplus e0 33 | fun tcpm0 () = ev_constplusminus e0 34 | fun tcpm1 () = ev_constplusminus e1 35 | (* 36 | fun tcm1 () = ev_constminus e1 37 | *) 38 | in 39 | test ("constplus(e0)", tcp0); 40 | test ("constplusminus(e0)", tcpm0); 41 | test ("constplusminus(e1)", tcpm1); 42 | 0 43 | end 44 | -------------------------------------------------------------------------------- /Tests/const2.mlpr: -------------------------------------------------------------------------------- 1 | let val m_nothing = nocases 2 | 3 | fun m_const ev m_other = 4 | cases `Const i => i 5 | default: m_other 6 | 7 | fun m_plus ev m_other = 8 | cases `Plus (x, y) => ev x + ev y 9 | default: m_other 10 | 11 | fun m_minus ev m_other = 12 | cases `Minus (x, y) => ev x - ev y 13 | default: m_other 14 | 15 | fun ev_constplus e = 16 | match e with 17 | m_plus ev_constplus 18 | (m_const ev_constplus 19 | m_nothing) 20 | 21 | fun ev_constplusminus e = 22 | match e with 23 | m_minus ev_constplusminus 24 | (m_plus ev_constplusminus 25 | (m_const ev_constplusminus 26 | m_nothing)) 27 | 28 | fun ev_constminus e = 29 | match e with 30 | m_minus ev_constminus 31 | (m_const ev_constminus 32 | m_nothing) 33 | 34 | fun ev_strange e = 35 | match e with 36 | m_minus ev_constplus 37 | (m_plus ev_constplusminus 38 | (m_const ev_constplusminus 39 | m_nothing)) 40 | 41 | val e0 = `Plus (`Const 1, `Plus (`Const 2, `Const 3)) 42 | val e1 = `Minus (e0, `Const 3) 43 | val e2 = `Minus (e0, `Minus (e0, `Const 3)) 44 | 45 | fun test (n, f) = 46 | String.output (String.concat [n, ": ", String.fromInt (f ()), "\n"]) 47 | 48 | fun foo r = (r.a, r) 49 | 50 | fun tcp0 () = ev_constplus e0 51 | fun tcpm0 () = ev_constplusminus e0 52 | fun tcpm1 () = ev_constplusminus e1 53 | fun foo () = ev_strange e1 54 | (* 55 | fun bar () = ev_strange e2 56 | *) 57 | (* 58 | fun tcm1 () = ev_constminus e1 59 | *) 60 | in 61 | test ("constplus(e0)", tcp0); 62 | test ("constplusminus(e0)", tcpm0); 63 | test ("constplusminus(e1)", tcpm1); 64 | 0 65 | end 66 | -------------------------------------------------------------------------------- /Tests/cps-better.mlpr: -------------------------------------------------------------------------------- 1 | let val n = { i := 1000 } 2 | fun withfresh f = let val i = n!i in n!i := i+1; f i end 3 | 4 | (* ---- utilities ---- *) 5 | 6 | fun Let (x, e1, e2) = `App (`Lam ([x], e2), [e1]) 7 | fun kv2kb kv = fn v => `App (kv, [v]) 8 | fun kb2kv kb = withfresh (fn rx => `Lam ([rx], kb (`Var rx))) 9 | 10 | fun cvt_app (cvt, e, el, kv) = 11 | let fun lc (el, kb) = 12 | case el of [] => kb [] 13 | | e :: el => pc (e, el, fn (v, vl) => kb (v :: vl)) 14 | and pc (e, el, kb) = cvt (e, fn v => lc (el, fn vl => kb (v, vl))) 15 | in pc (e, el, fn (v, vl) => `App (v, kv :: vl)) 16 | end 17 | 18 | fun cvt_lam (cvt, xl, e) = 19 | withfresh (fn xk => `Lam (xk :: xl, cvt (e, kv2kb (`Var xk)))) 20 | 21 | fun cvt_c (cvt, kb) = 22 | cases `Const i => kb (`Const i) 23 | | `Var x => kb (`Var x) 24 | | `Lam (xl, e) => kb (cvt_lam (cvt, xl, e)) 25 | | `App (e, el) => cvt_app (cvt, e, el, kb2kv kb) 26 | 27 | fun mkConvert (c, e) = 28 | let fun cvt (e, kb) = match e with c (cvt, kb) 29 | in cvt_lam (cvt, [], e) 30 | end 31 | 32 | fun convert e = mkConvert (cvt_c, e) 33 | 34 | fun cvt_if_c other (cvt, kb) = 35 | cases `If (e1, e2, e3) => 36 | withfresh (fn xk => 37 | Let (xk, kb2kv kb, cvt (e1, fn v1 => 38 | let val kb' = kv2kb (`Var xk) 39 | in `If (v1, cvt (e2, kb'), cvt (e3, kb')) 40 | end))) 41 | default: other (cvt, kb) 42 | 43 | fun cvt_lcc_c other (cvt, kb) = 44 | cases `LetCC (x, e) => ... 45 | default: other (cvt, kb) 46 | 47 | fun convert_if e = mkConvert (cvt_if_c cvt_c, e) 48 | 49 | 50 | in 0 51 | end 52 | -------------------------------------------------------------------------------- /Tests/cps-convert-cc.mlpr: -------------------------------------------------------------------------------- 1 | let val n = {| i = 1000 |} 2 | fun new f = let val i = n!i in n!i := i+1; f i end 3 | 4 | fun app_cvt (cvt, e, el, kx) = 5 | let fun lc (el, k) = 6 | case el of [] => k [] 7 | | e :: el => pc (e, el, fn (x, xl) => k (x :: xl)) 8 | and pc (e, el, k) = cvt (e, fn x => lc (el, fn xl => k (x, xl))) 9 | in pc (e, el, fn (x, xl) => `App (x, kx :: xl)) 10 | end 11 | 12 | (* conversion match for values (anything but App) *) 13 | fun value_cvt_m tail_cvt k = 14 | cases `Const i => k (`Const i) 15 | | `Var v => k (`Var v) 16 | | `Lam (vl, e) => 17 | new (fn kv => k (`Lam (kv :: vl, tail_cvt (e, kv)))) 18 | 19 | fun app_cvt_m cvt k other = 20 | cases `App (e, el) => 21 | new (fn v => app_cvt (cvt, e, el, `Lam ([v], k (`Var v)))) 22 | default: other 23 | 24 | fun app_cvt_t_m cvt kv other = 25 | cases `App (e, el) => app_cvt (cvt, e, el, `Var kv) 26 | default: other 27 | 28 | fun kv2k kv x = `App (`Var kv, [x]) 29 | 30 | fun convert e = 31 | let fun cvt (e, k) = 32 | match e with app_cvt_m cvt k (value_cvt_m tail_cvt k) 33 | and tail_cvt (e, kv) = 34 | match e with app_cvt_t_m cvt kv (value_cvt_m tail_cvt (kv2k kv)) 35 | in new (fn k0v => `Lam ([k0v], tail_cvt (e, k0v))) 36 | end 37 | 38 | fun lcc_cvt (tail_cvt, ccv, e, kv) = 39 | new (fn dummyv => new (fn resv => 40 | `App (`Lam ([ccv], tail_cvt (e, kv)), 41 | [`Lam ([dummyv, resv], 42 | `App (`Var kv, [`Var resv]))]))) 43 | 44 | fun lcc_cvt_m tail_cvt k other = 45 | cases `LetCC (ccv, e) => 46 | new (fn kv => new (fn kresv => 47 | `App (`Lam ([kv], lcc_cvt (tail_cvt, ccv, e, kv)), 48 | [`Lam ([kresv], k (`Var kresv))]))) 49 | default: other 50 | 51 | fun lcc_cvt_t_m tail_cvt kv other = 52 | cases `LetCC (ccv, e) => lcc_cvt (tail_cvt, ccv, e, kv) 53 | default: other 54 | 55 | fun convert_lcc e = 56 | let fun cvt (e, k) = 57 | match e with app_cvt_m cvt k 58 | (lcc_cvt_m tail_cvt k (value_cvt_m tail_cvt k)) 59 | and tail_cvt (e, kv) = 60 | match e with app_cvt_t_m cvt kv 61 | (lcc_cvt_t_m tail_cvt kv 62 | (value_cvt_m tail_cvt (kv2k kv))) 63 | in new (fn k0v => `Lam ([k0v], tail_cvt (e, k0v))) 64 | end 65 | 66 | fun out s = String.output s 67 | fun var v = (out "x"; out (String.fromInt v)) 68 | 69 | (* print a list using f for elements: *) 70 | fun list (f, xs) = case xs of [] => () | x :: xs => list_ne (f, x, xs) 71 | (* print a non-empty list (head x, tail xs): *) 72 | and list_ne (f, x, xs) = 73 | (f x; case xs of [] => () | x :: xs => (out ","; list_ne (f, x, xs))) 74 | 75 | (* match for printing values *) 76 | fun print_value_m exp = 77 | cases `Const i => out (String.fromInt i) 78 | | `Var v => var v 79 | | `Lam (vl, e) => (out "\\("; list (var, vl); out ")."; exp e) 80 | 81 | (* match for printing general expressions *) 82 | fun print_exp_m { body, arg } = 83 | cases `App (a, al) => (arg a; out "("; list (arg, al); out ")") 84 | default: print_value_m body 85 | 86 | (* printer for general lambda expressions *) 87 | fun print e = 88 | let fun exp e = match e with 89 | cases `LetCC (ccv, e) => 90 | (out "letcc "; var ccv; out " in "; exp e ; out " end") 91 | default: print_exp_m { body = exp, arg = exp } 92 | in exp e; out "\n" 93 | end 94 | 95 | (* printer for lambda expressions that satisfy CPS invariant *) 96 | fun print_cps e = 97 | let fun value x = match x with print_value_m exp 98 | and exp e = match e with print_exp_m { body = exp, arg = value } 99 | in value e; out "\n" 100 | end 101 | 102 | (* test case: *) 103 | val e = `Lam ([0,1,2], `App (`Var 0, [`App (`Var 1, [`Var 2])])) 104 | val ecc = `LetCC (0, `App (`Var 0, [`Const 10])) 105 | in print e; 106 | print (convert e); 107 | print_cps (convert e); 108 | print ecc; 109 | print (convert_lcc ecc); 110 | print_cps (convert_lcc ecc); 111 | (* These would be type errors: 112 | print_cps e; 113 | print_cps ecc; 114 | *) 115 | 0 116 | end 117 | -------------------------------------------------------------------------------- /Tests/cps-convert-cc2.mlpr: -------------------------------------------------------------------------------- 1 | let val n = {| i = 1000 |} 2 | fun withfresh f = let val i = n!i in n!i := i+1; f i end 3 | fun out s = String.output s 4 | 5 | (* ---- utilities ---- *) 6 | 7 | fun Let (x, e1, e2) = `App (`Lam ([x], e2), [e1]) 8 | fun kx2kb kx v = `App (`Var kx, [v]) 9 | fun kb2kv kb = withfresh (fn x => `Lam ([x], kb (`Var x))) 10 | fun exceptApp `{ App, ... = other } = other 11 | 12 | (* converter for App, given the continuation value kv *) 13 | fun app_cvt (cvt, e, el, kv) = 14 | let fun cl (el, kb) = 15 | case el of [] => kb [] 16 | | e::el => cvt (e, fn v => cl (el, fn vl => kb (v::vl))) 17 | in cvt (e, fn v => cl (el, fn vl => `App (v, kv::vl))) 18 | end 19 | 20 | (* converter for Lam, given the continuation builder k *) 21 | fun lam_cvt (tail_cvt, xl, e) = 22 | withfresh (fn kx => `Lam (kx :: xl, tail_cvt (e, kx))) 23 | 24 | (* make a converter given the generic and tail match makers 25 | * by tying the recursive knot: *) 26 | fun mkConvert (cvt_m, cvt_t_m, e) = 27 | let fun cvt (e, kb) = match e with cvt_m cvt tail_cvt kb 28 | and tail_cvt (e, kx) = match e with cvt_t_m cvt tail_cvt kx 29 | in lam_cvt (tail_cvt, [], e) 30 | end 31 | 32 | (* conversion match for expressions in general position *) 33 | fun cvt_m cvt tail_cvt kb = 34 | cases `Const i => kb (`Const i) 35 | | `Var x => kb (`Var x) 36 | | `Lam (xl, e) => kb (lam_cvt (tail_cvt, xl, e)) 37 | | `App (e, el) => app_cvt (cvt, e, el, kb2kv kb) 38 | 39 | (* conversion match for expression in tail position *) 40 | fun cvt_t_m cvt tail_cvt kx = 41 | cases `App (e, el) => app_cvt (cvt, e, el, `Var kx) 42 | default: exceptApp (cvt_m cvt tail_cvt (kx2kb kx)) 43 | 44 | (* instantiate converter for lambda expressions: *) 45 | fun convert e = mkConvert (cvt_m, cvt_t_m, e) 46 | 47 | (* ---- now let's do LetCC ---- *) 48 | 49 | (* converter for LetCC given the continuation variable kv *) 50 | fun lcc_cvt (tail_cvt, cx, e, kx) = 51 | withfresh (fn d => withfresh (fn r => 52 | Let (cx, `Lam ([d, r], `App (`Var kx, [`Var r])), tail_cvt (e, kx)))) 53 | 54 | (* conversion match for LetCC-enhanced expressions in general position *) 55 | fun cvt_cc_m cvt tail_cvt kb = 56 | cases `LetCC (cx, e) => withfresh (fn kx => 57 | Let (kx, kb2kv kb, lcc_cvt (tail_cvt, cx, e, kx))) 58 | default: cvt_m cvt tail_cvt kb 59 | 60 | (* conversion match for LetCC-enhanced expressions in tail position: *) 61 | fun cvt_cc_t_m cvt tail_cvt kv = 62 | cases `LetCC (ccx, e) => lcc_cvt (tail_cvt, ccx, e, kv) 63 | default: cvt_t_m cvt tail_cvt kv 64 | 65 | (* instantiate converter for LetCC-enhanced lambda expressions: *) 66 | fun convert_cc e = mkConvert (cvt_cc_m, cvt_cc_t_m, e) 67 | 68 | (* ---- evaluation ---- *) 69 | 70 | fun map f l = case l of [] => [] | h :: t => f h :: map f t 71 | fun bind (x, v, env) x' = if x == x' then v else env x' 72 | fun bindl (xl, vl, env) = 73 | case xl of 74 | [] => env 75 | | x :: xl => 76 | (case vl of 77 | [] => env (* really an error! *) 78 | | v :: vl => bind (x, v, bindl (xl, vl, env))) 79 | 80 | fun eval_v_m env = 81 | cases `Const i => `Int i 82 | | `Var x => env x 83 | | `Lam (xl, e) => `Fun (xl, e, env) 84 | 85 | fun eval_v env v = match v with eval_v_m env 86 | 87 | fun eval_m env eval = 88 | cases `App (e, el) => 89 | let val v = eval env e 90 | val vl = map (eval env) el 91 | in match v with 92 | cases `Int i => (out "error: applied int"; `Int 0) 93 | | `Fun (xl, e, env) => eval (bindl (xl, vl, env)) e 94 | end 95 | default: eval_v_m env 96 | 97 | fun eval env e = match e with eval_m env eval 98 | 99 | fun eval_cps env e = match e with eval_m env eval_v 100 | 101 | (* ---- printing ---- *) 102 | 103 | fun var v = (out "x"; out (String.fromInt v)) 104 | fun par f x = (out "("; f x; out ")") 105 | fun sp () = out " " 106 | fun form (t, f, g, x, y) = (out "("; out t; sp (); f x; sp (); g y; out ")") 107 | 108 | (* print a non-empty list (head h, tail t): *) 109 | fun ht f (h, t) = (f h; case t of [] => () | h :: t => (sp (); ht f (h, t))) 110 | (* print a list using f for elements: *) 111 | fun list f xs = case xs of [] => () | x :: xs => ht f (x, xs) 112 | 113 | (* match for printing values *) 114 | fun print_value_m exp = 115 | cases `Const i => out (String.fromInt i) 116 | | `Var v => var v 117 | | `Lam (xl, e) => form ("lambda", par (list var), exp, xl, e) 118 | 119 | (* match for printing general expressions *) 120 | fun print_exp_m { body, arg } = 121 | cases `App (a, al) => par (ht arg) (a, al) 122 | default: print_value_m body 123 | 124 | (* printer for general lambda expressions *) 125 | fun print e = 126 | let fun exp e = match e with print_exp_m { body = exp, arg = exp } 127 | in exp e; out "\n" end 128 | 129 | (* printer for general lambda expressions, including LetCC *) 130 | fun print_cc e = 131 | let fun exp e = match e with 132 | cases `LetCC (ccx, e) => form ("letcc", var, exp, ccx, e) 133 | default: print_exp_m { body = exp, arg = exp } 134 | in exp e; out "\n" end 135 | 136 | (* printer for lambda expressions that satisfy CPS invariant *) 137 | fun print_cps e = 138 | let fun value v = match v with print_value_m exp 139 | and exp e = match e with print_exp_m { body = exp, arg = value } 140 | in value e; out "\n" end 141 | 142 | (* test case: *) 143 | val e = `Lam ([0,1,2], `App (`Var 0, [`App (`Var 1, [`Var 2])])) 144 | val ecc = `LetCC (0, `App (`Var 0, [`Const 10])) 145 | in print e; 146 | print (convert e); 147 | print_cps (convert e); 148 | 149 | (* This would be a type error: 150 | print ecc; 151 | *) 152 | print_cc ecc; 153 | print (convert_cc ecc); 154 | print_cps (convert_cc ecc); 155 | 156 | (* These would be type errors: 157 | print_cps e; 158 | print_cps ecc; 159 | *) 160 | 0 161 | end 162 | -------------------------------------------------------------------------------- /Tests/cps-convert.mlpr: -------------------------------------------------------------------------------- 1 | let fun convert e = 2 | let val n = {| i = 1000 |} 3 | fun newvar f = let val i = n!i in n!i := i+1; f i end 4 | 5 | (* conversion match for values (anything but App) *) 6 | fun value_cvt_m k = 7 | cases `Const i => k (`Const i) 8 | | `Var v => k (`Var v) 9 | | `Lam (vl, e) => 10 | newvar (fn kv => k (`Lam (kv :: vl, tail_cvt (e, kv)))) 11 | 12 | (* converter for expressions in general (non-tail) position *) 13 | and cvt (e, k) = match e with 14 | cases `App (e, el) => 15 | newvar (fn v => app_cvt (e, el, `Lam ([v], k (`Var v)))) 16 | default: value_cvt_m k 17 | 18 | (* converter for expressions in tail position *) 19 | and tail_cvt (e, kv) = match e with 20 | cases `App (e, el) => app_cvt (e, el, `Var kv) 21 | default: value_cvt_m (fn x => `App (`Var kv, [x])) 22 | 23 | (* converter for applications, kx represents continuation value *) 24 | and app_cvt (e, el, kx) = 25 | cvt (e, fn x => list_cvt (el, fn xl => `App (x, kx :: xl))) 26 | 27 | (* converter for expression lists *) 28 | and list_cvt (el, k) = case el of 29 | [] => k [] 30 | | h :: t => cvt (h, fn vh => list_cvt (t, fn vt => k (vh :: vt))) 31 | in (* k0v represents the global continutaion: *) 32 | newvar (fn k0v => `Lam ([k0v], tail_cvt (e, k0v))) 33 | end 34 | 35 | fun out s = String.output s 36 | fun var v = (out "x"; out (String.fromInt v)) 37 | 38 | (* print a list using f for elements: *) 39 | fun list (f, xs) = case xs of [] => () | x :: xs => list_ne (f, x, xs) 40 | (* print a non-empty list (head x, tail xs): *) 41 | and list_ne (f, x, xs) = 42 | (f x; case xs of [] => () | x :: xs => (out ","; list_ne (f, x, xs))) 43 | 44 | (* match for printing values *) 45 | fun print_value_m exp = 46 | cases `Const i => out (String.fromInt i) 47 | | `Var v => var v 48 | | `Lam (vl, e) => (out "\\("; list (var, vl); out ")."; exp e) 49 | 50 | (* match for printing general expressions *) 51 | fun print_exp_m { body, arg } = 52 | cases `App (a, al) => (arg a; out "("; list (arg, al); out ")") 53 | default: print_value_m body 54 | 55 | (* printer for general lambda expressions *) 56 | fun print e = 57 | let fun exp e = match e with print_exp_m { body = exp, arg = exp } 58 | in exp e; out "\n" 59 | end 60 | 61 | (* printer for lambda expressions that satisfy CPS invariant *) 62 | fun print_cps e = 63 | let fun value x = match x with print_value_m exp 64 | and exp e = match e with print_exp_m { body = exp, arg = value } 65 | in value e; out "\n" 66 | end 67 | 68 | (* test case: *) 69 | val e = `Lam ([0,1,2], `App (`Var 0, [`App (`Var 1, [`Var 2])])) 70 | in print e; 71 | print (convert e); 72 | print_cps (convert e); 73 | (* This would be a type error: 74 | print_cps e; 75 | *) 76 | 0 77 | end 78 | -------------------------------------------------------------------------------- /Tests/cps-convert1.sml: -------------------------------------------------------------------------------- 1 | structure CPS = struct 2 | 3 | datatype lexp = 4 | LCONST of int 5 | | LVAR of int 6 | | LLAM of int list * lexp 7 | | LAPP of lexp * lexp list 8 | 9 | datatype cvalue = 10 | CCONST of int 11 | | CVAR of int 12 | | CLAM of int list * cexp 13 | 14 | and cexp = 15 | CVALUE of cvalue 16 | | CAPP of cvalue * cvalue list 17 | 18 | fun convert e = 19 | let val n = ref 1000 20 | fun withnew f = let val i = !n in n := i+1; f i end 21 | 22 | fun cvt (e, k) = 23 | case e of 24 | LAPP (e, el) => 25 | withnew (fn v => app_cvt (e, el, CLAM ([v], k (CVAR v)))) 26 | | LCONST i => k (CCONST i) 27 | | LVAR v => k (CVAR v) 28 | | LLAM (vl, e) => 29 | withnew (fn kv => k (CLAM (kv :: vl, tail_cvt (e, kv)))) 30 | 31 | and tail_cvt (e, kv) = 32 | case e of 33 | LAPP (e, el) => app_cvt (e, el, CVAR kv) 34 | | e => cvt (e, fn x => CAPP (CVAR kv, [x])) 35 | 36 | and app_cvt (e, el, kx) = 37 | cvt (e, fn x => list_cvt (el, fn xl => CAPP (x, kx :: xl))) 38 | 39 | and list_cvt (el, k) = 40 | case el of 41 | [] => k [] 42 | | h :: t => 43 | cvt (h, fn vh => list_cvt (t, fn vt => k (vh :: vt))) 44 | in withnew (fn k0v => CLAM ([k0v], tail_cvt (e, k0v))) 45 | end 46 | 47 | end 48 | -------------------------------------------------------------------------------- /Tests/cps-convert2.sml: -------------------------------------------------------------------------------- 1 | structure CPS = struct 2 | 3 | datatype lexp = 4 | LCONST of int 5 | | LVAR of int 6 | | LLAM of int list * lexp 7 | | LAPP of lexp * lexp list 8 | 9 | datatype cvalue = 10 | CCONST of int 11 | | CVAR of int 12 | | CLAM of int list * cexp 13 | 14 | and cexp = 15 | CVALUE of cvalue 16 | | CAPP of cvalue * cvalue list 17 | 18 | fun convert e = 19 | let val n = ref 1000 20 | fun withnew f = let val i = !n in n := i+1; f i end 21 | 22 | fun value_cvt (e, k) = 23 | case e of 24 | LCONST i => k (CCONST i) 25 | | LVAR v => k (CVAR v) 26 | | LLAM (vl, e) => 27 | withnew (fn kv => k (CLAM (kv :: vl, tail_cvt (e, kv)))) 28 | | LAPP _ => raise Fail "unexpected LAPP" 29 | 30 | and cvt (e, k) = 31 | case e of 32 | LAPP (e, el) => 33 | withnew (fn v => app_cvt (e, el, CLAM ([v], k (CVAR v)))) 34 | | e => value_cvt (e, fn x => CVALUE x) 35 | 36 | and tail_cvt (e, kv) = 37 | case e of 38 | LAPP (e, el) => app_cvt (e, el, CVAR kv) 39 | | e => value_cvt (e, fn x => CAPP (CVAR kv, [x])) 40 | 41 | and app_cvt (e, el, kx) = 42 | cvt (e, fn x => list_cvt (el, fn xl => CAPP (x, kx :: xl))) 43 | 44 | and list_cvt (el, k) = 45 | case el of 46 | [] => k [] 47 | | h :: t => 48 | cvt (h, fn vh => list_cvt (t, fn vt => k (vh :: vt))) 49 | in withnew (fn k0v => CLAM ([k0v], tail_cvt (e, k0v))) 50 | end 51 | 52 | end 53 | -------------------------------------------------------------------------------- /Tests/cps-convert3.sml: -------------------------------------------------------------------------------- 1 | structure CPS = struct 2 | 3 | datatype lvalue = 4 | LCONST of int 5 | | LVAR of int 6 | | LLAM of int list * lexp 7 | 8 | and lexp = 9 | LVALUE of lvalue 10 | | LAPP of lexp * lexp list 11 | 12 | datatype cvalue = 13 | CCONST of int 14 | | CVAR of int 15 | | CLAM of int list * cexp 16 | 17 | and cexp = 18 | CVALUE of cvalue 19 | | CAPP of cvalue * cvalue list 20 | 21 | fun convert e = 22 | let val n = ref 1000 23 | fun withnew f = let val i = !n in n := i+1; f i end 24 | 25 | fun value_cvt (e, k) = 26 | case e of 27 | LCONST i => k (CCONST i) 28 | | LVAR v => k (CVAR v) 29 | | LLAM (vl, e) => 30 | withnew (fn kv => k (CLAM (kv :: vl, tail_cvt (e, kv)))) 31 | 32 | and cvt (e, k) = 33 | case e of 34 | LAPP (e, el) => 35 | withnew (fn v => app_cvt (e, el, CLAM ([v], k (CVAR v)))) 36 | | LVALUE e => value_cvt (e, fn x => CVALUE x) 37 | 38 | and tail_cvt (e, kv) = 39 | case e of 40 | LAPP (e, el) => app_cvt (e, el, CVAR kv) 41 | | LVALUE e => value_cvt (e, fn x => CAPP (CVAR kv, [x])) 42 | 43 | and app_cvt (e, el, kx) = 44 | cvt (e, fn x => list_cvt (el, fn xl => CAPP (x, kx :: xl))) 45 | 46 | and list_cvt (el, k) = 47 | case el of 48 | [] => k [] 49 | | h :: t => 50 | cvt (h, fn vh => list_cvt (t, fn vt => k (vh :: vt))) 51 | in withnew (fn k0v => CLAM ([k0v], tail_cvt (e, k0v))) 52 | end 53 | 54 | end 55 | -------------------------------------------------------------------------------- /Tests/cps-convert4.sml: -------------------------------------------------------------------------------- 1 | structure CPS = struct 2 | 3 | datatype 'body value = 4 | CONST of int 5 | | VAR of int 6 | | LAM of int list * 'body 7 | 8 | datatype ('arg, 'body) exp = 9 | VALUE of 'body value 10 | | APP of 'arg * 'arg list 11 | 12 | datatype lexp = L of (lexp, lexp) exp 13 | 14 | datatype cexp = C of (cexp value, cexp) exp 15 | 16 | fun convert e = 17 | let val n = ref 1000 18 | fun withnew f = let val i = !n in n := i+1; f i end 19 | 20 | fun value_cvt (x, k) = 21 | case x of 22 | CONST i => k (CONST i) 23 | | VAR v => k (VAR v) 24 | | LAM (vl, e) => 25 | withnew (fn kv => k (LAM (kv :: vl, tail_cvt (e, kv)))) 26 | 27 | and cvt (L e, k) = 28 | case e of 29 | APP (e, el) => 30 | withnew (fn v => app_cvt (e, el, LAM ([v], k (VAR v)))) 31 | | VALUE e => value_cvt (e, fn x => C (VALUE x)) 32 | 33 | and tail_cvt (L e, kv) = 34 | case e of 35 | APP (e, el) => app_cvt (e, el, VAR kv) 36 | | VALUE e => value_cvt (e, fn x => C (APP (VAR kv, [x]))) 37 | 38 | and app_cvt (e, el, kx) = 39 | cvt (e, fn x => list_cvt (el, fn xl => C (APP (x, kx :: xl)))) 40 | 41 | and list_cvt (el, k) = 42 | case el of 43 | [] => k [] 44 | | h :: t => 45 | cvt (h, fn vh => list_cvt (t, fn vt => k (vh :: vt))) 46 | in withnew (fn k0v => LAM ([k0v], tail_cvt (e, k0v))) 47 | end 48 | end 49 | -------------------------------------------------------------------------------- /Tests/cps-improved.mlpr: -------------------------------------------------------------------------------- 1 | let val n = {| i = 1000 |} 2 | fun withfresh f = let val i = n!i in n!i := i+1; f i end 3 | 4 | (* ---- utilities ---- *) 5 | 6 | fun Let (x, e1, e2) = `App (`Lam ([x], e2), [e1]) 7 | fun kv2kb kv = fn v => `App (kv, [v]) 8 | fun kb2kv kb = withfresh (fn rx => `Lam ([rx], kb (`Var rx))) 9 | 10 | fun cvt_app (cvt, e, el, kv) = 11 | let fun lc (el, kb) = 12 | case el of [] => kb [] 13 | | e :: el => pc (e, el, fn (v, vl) => kb (v :: vl)) 14 | and pc (e, el, kb) = cvt (e, fn v => lc (el, fn vl => kb (v, vl))) 15 | in pc (e, el, fn (v, vl) => `App (v, kv :: vl)) 16 | end 17 | 18 | fun cvt_lam (tcvt, xl, e) = 19 | withfresh (fn xk => `Lam (xk :: xl, tcvt (e, xk))) 20 | 21 | fun vcvt_m (tcvt, kb) = 22 | cases `Con i => kb (`Con i) 23 | | `Var x => kb (`Var x) 24 | | `Lam (xl, e) => kb (cvt_lam (tcvt, xl, e)) 25 | 26 | fun cvt_m (cvt, tcvt, kb) = 27 | cases `App (e, el) => cvt_app (cvt, e, el, kb2kv kb) 28 | default: vcvt_m (tcvt, kb) 29 | 30 | fun tcvt_m (cvt, tcvt, xk) = 31 | cases `App (e, el) => cvt_app (cvt, e, el, `Var xk) 32 | default: vcvt_m (tcvt, kv2kb (`Var xk)) 33 | 34 | fun mkConvert (cvt_m, tcvt_m, e) = 35 | let fun cvt (e, kb) = match e with cvt_m (cvt, tcvt, kb) 36 | and tcvt (e, xk) = match e with tcvt_m (cvt, tcvt, xk) 37 | in cvt_lam (tcvt, [], e) 38 | end 39 | 40 | fun convert e = mkConvert (cvt_m, tcvt_m, e) 41 | 42 | fun cvt_if (cvt, tcvt, c, t, e, xk) = 43 | cvt (c, fn cv => `If (cv, tcvt (t, xk), tcvt (e, xk))) 44 | 45 | fun cvti_m (cvt, tcvt, kb) = 46 | cases `If (c, t, e) => withfresh (fn xk => 47 | Let (xk, kb2kv kb, cvt_if (cvt, tcvt, c, t, e, xk))) 48 | default: cvt_m (cvt, tcvt, kb) 49 | 50 | fun tcvti_m (cvt, tcvt, xk) = 51 | cases `If (c, t, e) => cvt_if (cvt, tcvt, c, t, e, xk) 52 | default: tcvt_m (cvt, tcvt, xk) 53 | 54 | fun convert_if e = mkConvert (cvti_m, tcvti_m, e) 55 | 56 | fun cvt_lcc (tcvt, xc, e, xk) = 57 | withfresh (fn xd => withfresh (fn xr => 58 | Let (xc, `Lam ([xd, xr], `App (`Var xk, [`Var xr])), tcvt (e, xk)))) 59 | 60 | fun cvtc_m (cvt, tcvt, kb) = 61 | cases `LetCC (xc, e) => 62 | withfresh (fn xk => Let (xk, kb2kv kb, 63 | cvt_lcc (tcvt, xc, e, xk))) 64 | default: cvt_m (cvt, tcvt, kb) 65 | 66 | fun tcvtc_m (cvt, tcvt, xk) = 67 | cases `LetCCC (xc, e) => cvt_lcc (tcvt, xc, e, xk) 68 | default: tcvt_m (cvt, tcvt, xk) 69 | 70 | fun convertc e = mkConvert (cvtc_m, tcvtc_m, e) 71 | 72 | fun check e = 73 | let fun ignore _ = () 74 | fun int i = ignore (i+1) 75 | fun var v = int v 76 | fun app f l = case l of [] => () | h :: t => (f h; app f t) 77 | in match e with 78 | cases `Con i => int i 79 | | `Var v => var v 80 | | `Lam (xl, e) => (app var xl; check e) 81 | | `App (e, el) => (check e; app check el) 82 | | `If (e1, e2, e3) => (check e1; check e2; check e3) 83 | | `LetCC (x, e) => (var x; check e) 84 | end 85 | 86 | fun check_convert e = check (convert e) 87 | fun check_convert_if e = check (convert_if e) 88 | fun check_convertc e = check (convertc e) 89 | 90 | in 0 91 | end 92 | -------------------------------------------------------------------------------- /Tests/cps-naive.mlpr: -------------------------------------------------------------------------------- 1 | let val n = {| i = 1000 |} 2 | fun withfresh f = let val i = n!i in n!i := i+1; f i end 3 | 4 | (* ---- utilities ---- *) 5 | 6 | fun Let (x, e1, e2) = `App (`Lam ([x], e2), [e1]) 7 | fun kv2kb kv = fn v => `App (kv, [v]) 8 | fun kb2kv kb = withfresh (fn rx => `Lam ([rx], kb (`Var rx))) 9 | 10 | fun cvt_app (e, el, kv) = 11 | let fun lc (el, kb) = 12 | case el of [] => kb [] 13 | | e :: el => pc (e, el, fn (v, vl) => kb (v :: vl)) 14 | and pc (e, el, kb) = cvt (e, fn v => lc (el, fn vl => kb (v, vl))) 15 | in pc (e, el, fn (v, vl) => `App (v, kv :: vl)) 16 | end 17 | 18 | and cvt_lam (xl, e) = 19 | withfresh (fn xk => `Lam (xk :: xl, cvt (e, kv2kb (`Var xk)))) 20 | 21 | and cvt (e, kb) = match e with 22 | cases `Const i => kb (`Const i) 23 | | `Var x => kb (`Var x) 24 | | `Lam (xl, e) => kb (cvt_lam (xl, e)) 25 | | `App (e, el) => cvt_app (e, el, kb2kv kb) 26 | 27 | fun convert e = cvt_lam ([], e) 28 | in 0 29 | end 30 | -------------------------------------------------------------------------------- /Tests/cps-withcases.mlpr: -------------------------------------------------------------------------------- 1 | let val n = {| i = 1000 |} 2 | fun withfresh f = let val i = n!i in n!i := i+1; f i end 3 | 4 | (* ---- utilities ---- *) 5 | 6 | fun Let (x, e1, e2) = `App (`Lam ([x], e2), [e1]) 7 | fun kv2kb kv = fn v => `App (kv, [v]) 8 | fun kb2kv kb = withfresh (fn rx => `Lam ([rx], kb (`Var rx))) 9 | 10 | fun cvt_app (cvt, e, el, kv) = 11 | let fun lc (el, kb) = 12 | case el of [] => kb [] 13 | | e :: el => pc (e, el, fn (v, vl) => kb (v :: vl)) 14 | and pc (e, el, kb) = cvt (e, fn v => lc (el, fn vl => kb (v, vl))) 15 | in pc (e, el, fn (v, vl) => `App (v, kv :: vl)) 16 | end 17 | 18 | fun cvt_lam (cvt, xl, e) = 19 | withfresh (fn xk => `Lam (xk :: xl, cvt (e, kv2kb (`Var xk)))) 20 | 21 | fun cvt_c cvt = 22 | cases `Const i => (fn kb => kb (`Const i)) 23 | | `Var x => (fn kb => kb (`Var x)) 24 | | `Lam (xl, e) => (fn kb => kb (cvt_lam (cvt, xl, e))) 25 | | `App (e, el) => (fn kb => cvt_app (cvt, e, el, kb2kv kb)) 26 | 27 | fun mkConvert (c, e) = 28 | let fun cvt (e, kb) = (match e with cc) kb 29 | with cases cc = c cvt 30 | in cvt_lam (cvt, [], e) 31 | end 32 | 33 | fun convert e = mkConvert (cvt_c, e) 34 | 35 | fun cvt_if (cvt, c, t, e, xk) = 36 | cvt (c, fn cv => `If (cv, cvt (t, fn vt => `App (`Var xk, [vt])), 37 | cvt (e, fn ve => `App (`Var xk, [ve])))) 38 | 39 | fun cvt_if_c other_c cvt = 40 | cases `If (c, t, e) => 41 | (fn kb => withfresh (fn xk => 42 | Let (xk, kb2kv kb, cvt_if (cvt, c, t, e, xk)))) 43 | default: other_c cvt 44 | 45 | fun convert_if e = mkConvert (cvt_if_c cvt_c, e) 46 | 47 | (* 48 | fun cvt_lcc_c other_c (cvt, kb) = 49 | cases `LetCC (x, e) => ... 50 | default: other_c (cvt, kb) 51 | 52 | fun convert_lcc e = mkConvert (cvt_lcc_c cvt_c, e) 53 | 54 | fun convert_if_lcc e = mkConvert (cvt_lcc_c (cvt_if_c cvt_c), e) 55 | *) 56 | in 0 57 | end 58 | -------------------------------------------------------------------------------- /Tests/div.mlpr: -------------------------------------------------------------------------------- 1 | let val s2i = String.toInt 2 | fun print x = 3 | String.output (String.concat [String.fromInt x, "\n"]) 4 | in 5 | 6 | case String.cmdline_args of 7 | [] => 0 8 | | x :: l => 9 | (case l of 10 | y :: _ => (print (s2i x / s2i y); 0) 11 | | [] => 0) 12 | end 13 | -------------------------------------------------------------------------------- /Tests/echo.mlpr: -------------------------------------------------------------------------------- 1 | let fun loop (h, t) = 2 | case t of 3 | [] => (String.output h; String.output "\n"; 0) 4 | | th :: tt => (String.output h; String.output " "; loop (th, tt)) 5 | in String.output String.cmdline_pgm; 6 | String.output ": "; 7 | case String.cmdline_args of 8 | [] => 0 9 | | h :: t => loop (h, t) 10 | end 11 | -------------------------------------------------------------------------------- /Tests/evenodd.mlpr: -------------------------------------------------------------------------------- 1 | let fun even i = i == 0 orelse odd (i-1) 2 | and odd i = i <> 0 andalso even (i-1) 3 | in 0 4 | end 5 | -------------------------------------------------------------------------------- /Tests/exn-a-or-b.mlpr: -------------------------------------------------------------------------------- 1 | let fun seq (x, y) = String.compare (x, y) == 0 2 | val print = String.output 3 | fun f () = 4 | let val line = String.inputLine () 5 | in if seq (line, "A\n") then raise `A 1 6 | else if seq (line, "B\n") then raise `B true 7 | else 0 8 | end 9 | in 10 | try r = f () 11 | in r 12 | handling `A _ => (print "A\n"; 1) 13 | | exn => 14 | (match exn with 15 | cases `B b => (print (if b then "B true\n" 16 | else "B false\n"); 17 | 2)) 18 | end 19 | end 20 | -------------------------------------------------------------------------------- /Tests/exnabc.mlpr: -------------------------------------------------------------------------------- 1 | let val print = String.output 2 | fun checkabc () = 3 | let val line = String.inputLine () 4 | in if String.compare (line, "A\n") == 0 then raise `A 0 5 | else if String.compare (line, "B\n") == 0 then raise `B true 6 | else if String.compare (line, "C\n") == 0 then raise `C "hello" 7 | else if String.compare (line, "D\n") == 0 then raise `D () 8 | else String.output "good!\n" 9 | end 10 | 11 | fun b () = 12 | try r = checkabc () 13 | in r 14 | handling `B b => (print "B "; print (if b then "true" else "false"); print "\n") 15 | end 16 | 17 | fun a0 () = 18 | try r = b () 19 | in r 20 | rehandling `A i => (print "A "; print (String.fromInt i); print "\n"; 21 | raise `A (i+1)) 22 | end 23 | 24 | fun d () = 25 | try r = a0 () 26 | in r 27 | handling `D () => print "D ()\n" 28 | end 29 | 30 | fun a () = 31 | try r = d () 32 | in r 33 | handling `A i => (print "A "; print (String.fromInt i); print "\n") 34 | end 35 | 36 | fun c () = 37 | try r = a () 38 | in r 39 | handling `C s => (print "C \""; print s; print "\"\n") 40 | end 41 | 42 | in c (); 43 | 0 44 | end 45 | -------------------------------------------------------------------------------- /Tests/expr.mlpr: -------------------------------------------------------------------------------- 1 | let fun mkEval (c, e) = let fun ev e = match e with c ev in ev e end 2 | fun c0 ev = nocases 3 | 4 | (* -------------------- *) 5 | 6 | fun con_c other ev = 7 | cases `Con c => c 8 | default: other ev 9 | 10 | fun plus_c other ev = 11 | cases `Plus (x, y) => ev x + ev y 12 | default: other ev 13 | 14 | fun con_plus_c other = plus_c (con_c other) 15 | 16 | fun eval1 e = mkEval (con_plus_c c0, e) 17 | 18 | (* -------------------- *) 19 | 20 | fun times_c other ev = 21 | cases `Times (x, y) => ev x * ev y 22 | default: other ev 23 | 24 | fun con_plus_times_c other = times_c (con_plus_c other) 25 | 26 | fun eval2 e = mkEval (con_plus_times_c c0, e) 27 | 28 | (* -------------------- *) 29 | 30 | fun empty v = 31 | if String.compare (v, "a") == 0 then 100 32 | else (String.output "unbound!\n"; 0) 33 | 34 | fun var_c other ev env = 35 | cases `Var v => env v 36 | default: other ev env 37 | 38 | fun env_lift c other ev env = c other (ev env) 39 | 40 | fun mkEval_env (c, e) = 41 | let fun ev env e = match e with c ev env 42 | in ev empty e 43 | end 44 | 45 | fun eval3 e = 46 | mkEval_env (var_c (env_lift con_plus_times_c c0), e) 47 | 48 | fun test3 (e, expected) = 49 | String.output (String.concat ["expected: ", 50 | String.fromInt expected, 51 | ", calculated: ", 52 | String.fromInt (eval3 e), "\n"]) 53 | 54 | val e101 = `Plus (`Var "a", `Con 1) 55 | in String.output "*** going for it:\n"; 56 | test3 (e101, 101); 57 | 0 58 | end 59 | -------------------------------------------------------------------------------- /Tests/ext-rs.mlpr: -------------------------------------------------------------------------------- 1 | let fun xaug_ab (b, r, s) = 2 | if b then { a = 1, ... = r } 3 | else { b = true, ... = r } 4 | in 0 5 | end 6 | -------------------------------------------------------------------------------- /Tests/flat.mlpr: -------------------------------------------------------------------------------- 1 | let fun loop x = 2 | let val (x1, x2) = x 3 | val (x11, x12, x13) = x1 4 | val (x21, x22) = x2 5 | val (x131, x132, x133) = x13 6 | in if x131 == 0 then (x11, x12, x132, x133, x21, x22) 7 | else loop ((x11+1, x12+2, (x131-1, x132+3, x133+4)), (x21+5, x22+6)) 8 | end 9 | val (y11, y12, y132, y133, y21, y22) = loop ((0, 0, (10, 0, 0)), (0, 0)) 10 | fun i2s i = String.fromInt i 11 | fun print l = String.output (String.concat l) 12 | in print ["((", i2s y11, ",", i2s y12, ",(0,", i2s y132, ",", 13 | i2s y133, ")),(", i2s y21, ",", i2s y22, "))\n"]; 14 | 0 15 | end 16 | -------------------------------------------------------------------------------- /Tests/foo.mlpr: -------------------------------------------------------------------------------- 1 | let fun remove_a `{ a, ... = rest } = rest 2 | in 0 3 | end 4 | -------------------------------------------------------------------------------- /Tests/funupdate.mlpr: -------------------------------------------------------------------------------- 1 | let fun print l = String.output (String.concat l) 2 | fun pi what i = print [what, ": ", String.fromInt i, "\n"] 3 | fun test1 () = 4 | let fun addab r = 5 | let val x = r.a + r.b 6 | in pi "addab" x; 7 | x 8 | end 9 | in addab { a = 5, b = 7, c = "hello" } - 10 | addab { b = 23, a = 0 } * 11 | addab { z = 1, a = 22, y = 15, b = -1, x = 4 } 12 | end 13 | 14 | fun test2 () = 15 | let fun augmentc (r, x) = { ... = r, c = x } 16 | in (augmentc ({ a = 1 }, 8), augmentc ({ b = 2 }, "a string")) 17 | end 18 | in pi "test1" (test1 ()); 19 | let val ({ a, c = c1 }, { b, c = c2 }) = test2 () 20 | in pi "a" a; 21 | pi "c1" c1; 22 | pi "b" b; 23 | print ["c2: ", c2, "\n"] 24 | end; 25 | 0 26 | end 27 | -------------------------------------------------------------------------------- /Tests/interp.mlpr: -------------------------------------------------------------------------------- 1 | let fun bind env v x w = 2 | if String.compare (v, w) == 0 then x else env w 3 | 4 | fun e_con d = cases `Con c => c 5 | default: d 6 | 7 | fun e_plus ev d = cases `Plus (e, e') => ev e + ev e' 8 | default: d 9 | 10 | fun e_var env d = cases `Var v => env v 11 | default: d 12 | 13 | fun e_let ev env d = cases `Let (v, e, b) => ev (bind env v (ev env e)) b 14 | default: d 15 | 16 | fun eval env e = 17 | match e with 18 | e_con (e_plus (eval env) (e_var env (e_let eval env nocases))) 19 | 20 | fun eval_plusonly e = 21 | match e with e_con (e_plus eval_plusonly nocases) 22 | in 0 23 | end 24 | -------------------------------------------------------------------------------- /Tests/lastcons.mlpr: -------------------------------------------------------------------------------- 1 | let fun lastcons l = 2 | match l with 3 | cases `Cons (hd, rest) => 4 | (match rest with 5 | cases (more as `Cons _) => lastcons more 6 | | `Nil () => `Cons (hd, `Nil ())) 7 | fun inclast l = 8 | match lastcons l with 9 | cases `Cons (hd, tl) => 10 | (match tl with cases `Nil () => hd+1) 11 | in 12 | 0 13 | end 14 | -------------------------------------------------------------------------------- /Tests/loop.mlpr: -------------------------------------------------------------------------------- 1 | let fun loop () = 2 | let fun foo (x) = x.a 3 | in foo 4 | end 5 | 6 | val dummy = loop () 7 | 8 | in 0 9 | end 10 | -------------------------------------------------------------------------------- /Tests/mergesort.mlpr: -------------------------------------------------------------------------------- 1 | let fun prlist l = 2 | case l of 3 | [] => () 4 | | h :: t => 5 | case t of 6 | [] => String.output h 7 | | ht :: tt => (String.output h; String.output ", "; 8 | prlist t) 9 | 10 | fun prblist l = 11 | (String.output "["; prlist l; String.output "]") 12 | 13 | fun mergesort (lt, l) = 14 | let fun split (l, even, odd) = 15 | case l of 16 | [] => (even, odd) 17 | | h :: t => 18 | case t of 19 | [] => (h :: even, odd) 20 | | ht :: tt => split (tt, h :: even, ht :: odd) 21 | fun merge (l1, l2) = 22 | case l1 of 23 | [] => l2 24 | | h1 :: t1 => 25 | case l2 of 26 | [] => l1 27 | | h2 :: t2 => 28 | if lt (h1, h2) then h1 :: merge (t1, l2) 29 | else h2 :: merge (l1, t2) 30 | fun sort l = 31 | case l of 32 | [] => [] 33 | | h :: t => 34 | case t of 35 | [] => l 36 | | ht :: tt => let val p = split (l, [], []) 37 | in merge (sort p.1, sort p.2) 38 | end 39 | in sort l 40 | end 41 | 42 | fun length l = 43 | let fun loop (l, n) = 44 | case l of 45 | [] => n 46 | | _ :: t => loop (t, n+1) 47 | in loop (l, 0) 48 | end 49 | 50 | fun lt (s1, s2) = String.compare (s1, s2) < 0 51 | val args = String.cmdline_args 52 | val args_sorted = mergesort (lt, args) 53 | in String.output "sort"; 54 | prblist args; 55 | String.output " = "; 56 | prblist args_sorted; 57 | String.output (String.concat ["\nlength: ", 58 | String.fromInt (length args), 59 | "\n"]); 60 | 0 61 | end 62 | -------------------------------------------------------------------------------- /Tests/mergesort2.mlpr: -------------------------------------------------------------------------------- 1 | let fun mergesort (lt, l) = 2 | let fun split (l, even, odd) = 3 | case l of 4 | [] => (even, odd) 5 | | h :: t => 6 | case t of 7 | [] => (h :: even, odd) 8 | | ht :: tt => split (tt, h :: even, ht :: odd) 9 | fun merge (l1, l2) = 10 | case l1 of 11 | [] => l2 12 | | h1 :: t1 => 13 | case l2 of 14 | [] => l1 15 | | h2 :: t2 => 16 | if lt (h1, h2) then h1 :: merge (t1, l2) 17 | else h2 :: merge (l1, t2) 18 | fun sort l = 19 | case l of 20 | [] => [] 21 | | h :: t => 22 | case t of 23 | [] => l 24 | | ht :: tt => let val p = split (l, [], []) 25 | in merge (sort p.1, sort p.2) 26 | end 27 | in sort l 28 | end 29 | 30 | fun foldl f init l = 31 | case l of 32 | [] => init 33 | | h :: t => foldl f (f (h, init)) t 34 | 35 | fun reverse l = 36 | let fun cons (h, t) = h :: t 37 | in foldl cons [] l 38 | end 39 | 40 | fun app f l = 41 | case l of 42 | [] => () 43 | | h :: t => (f h; app f t) 44 | 45 | fun putlines ll = app String.output ll 46 | 47 | fun getlines ll = 48 | let val l = String.inputLine () 49 | in if String.size l == 0 then reverse ll 50 | else getlines (l :: ll) 51 | end 52 | 53 | fun stripnl s = 54 | let val sz = String.size s 55 | in if String.sub (s, sz-1) == 10 then 56 | String.substring (s, 0, sz-1) 57 | else s 58 | end 59 | 60 | fun lt (s1, s2) = String.compare (stripnl s1, stripnl s2) < 0 61 | val lines = getlines [] 62 | val sorted_lines = mergesort (lt, lines) 63 | in putlines sorted_lines; 64 | 0 65 | end 66 | -------------------------------------------------------------------------------- /Tests/mergesort3.mlpr: -------------------------------------------------------------------------------- 1 | let fun mergesort (lt, l) = 2 | let fun split (l, even, odd) = 3 | case l of 4 | [] => (even, odd) 5 | | h :: t => split (t, odd, h :: even) 6 | fun merge (l1, l2) = 7 | case l1 of 8 | [] => l2 9 | | h1 :: t1 => 10 | case l2 of 11 | [] => l1 12 | | h2 :: t2 => 13 | if lt (h1, h2) then h1 :: merge (t1, l2) 14 | else h2 :: merge (l1, t2) 15 | fun sort l = 16 | case l of 17 | [] => [] 18 | | h :: t => 19 | case t of 20 | [] => l 21 | | ht :: tt => let val p = split (l, [], []) 22 | in merge (sort p.1, sort p.2) 23 | end 24 | in sort l 25 | end 26 | 27 | fun foldl f init l = 28 | case l of 29 | [] => init 30 | | h :: t => foldl f (f (h, init)) t 31 | 32 | fun reverse l = 33 | let fun cons (h, t) = h :: t 34 | in foldl cons [] l 35 | end 36 | 37 | fun app f l = 38 | case l of 39 | [] => () 40 | | h :: t => (f h; app f t) 41 | 42 | fun putlines ll = app String.output ll 43 | 44 | fun getlines ll = 45 | let val l = String.inputLine () 46 | in if String.size l == 0 then reverse ll 47 | else getlines (l :: ll) 48 | end 49 | 50 | fun stripnl s = 51 | let val sz = String.size s 52 | in if String.sub (s, sz-1) == 10 then 53 | String.substring (s, 0, sz-1) 54 | else s 55 | end 56 | 57 | fun lt (s1, s2) = String.compare (stripnl s1, stripnl s2) < 0 58 | val lines = getlines [] 59 | val sorted_lines = mergesort (lt, lines) 60 | in putlines sorted_lines; 61 | 0 62 | end 63 | -------------------------------------------------------------------------------- /Tests/mod.mlpr: -------------------------------------------------------------------------------- 1 | let fun s2i x = String.toInt x 2 | fun i2s x = String.fromInt x 3 | 4 | fun showmod (x, y) = 5 | String.output (String.concat [x, " mod ", y, " = ", 6 | i2s (s2i x % s2i y), "\n"]) 7 | 8 | fun loop l = 9 | case l of 10 | [] => 0 11 | | h :: t => 12 | case t of 13 | [] => 1 14 | | ht :: tt => (showmod (h, ht); loop tt) 15 | 16 | in loop String.cmdline_args 17 | end 18 | -------------------------------------------------------------------------------- /Tests/mono-capture.mlpr: -------------------------------------------------------------------------------- 1 | let val { a, b, ... = r } = { a = 1, b = 11, c = 22, d = 44, e = 5 } 2 | fun itos i = String.fromInt i 3 | in String.output (String.concat [itos a, " ", itos b, " ", 4 | itos r.c, " ", itos r.d, "\n"]); 5 | 0 6 | end 7 | -------------------------------------------------------------------------------- /Tests/mono-extend.mlpr: -------------------------------------------------------------------------------- 1 | let fun print l = String.output (String.concat l) 2 | fun show what x = (print ["show: ", what, "\n"]; x) 3 | fun f r = 4 | let val { a, b, c, d } = 5 | { a = show "a" 1, ... = show "..." r, c = show "c" 2 } 6 | in (a, b, c, d) 7 | end 8 | val (a, b, c, d) = f { b = 3, d = 4 } 9 | fun i2s i = String.fromInt i 10 | in print [i2s a, " ", i2s b, " ", i2s c, " ", i2s d, "\n"]; 11 | 0 12 | end 13 | -------------------------------------------------------------------------------- /Tests/mono-replace.mlpr: -------------------------------------------------------------------------------- 1 | let fun print l = String.output (String.concat l) 2 | fun f r = 3 | let val { a, b, c, d } = r where { a = 1, c = 2 } 4 | in (a, b, c, d) 5 | end 6 | val (a, b, c, d) = f { a = -1, b = 3, c = -2, d = 4 } 7 | fun i2s i = String.fromInt i 8 | in print [i2s a, " ", i2s b, " ", i2s c, " ", i2s d, "\n"]; 9 | 0 10 | end 11 | -------------------------------------------------------------------------------- /Tests/nat.mlpr: -------------------------------------------------------------------------------- 1 | let fun two_n n = 2 | if n == 0 then `Zero () 3 | else `Succ (`Succ (two_n (n-1))) 4 | fun two_n_plus_1 n = `Succ (two_n n) 5 | 6 | fun nat2int n = 7 | match n with 8 | cases `Zero () => 0 9 | | `Succ n => nat2int n + 1 10 | 11 | fun double i = nat2int (two_n i) 12 | fun doubleplus i = nat2int (two_n_plus_1 i) 13 | 14 | fun test (what, f, i) = 15 | String.output (String.concat [what, "(", String.fromInt i, ")=", 16 | String.fromInt (f i), "\n"]) 17 | in test ("double", double, 10); 18 | test ("doubleplus", doubleplus, 10); 19 | 0 20 | end 21 | -------------------------------------------------------------------------------- /Tests/neg.mlpr: -------------------------------------------------------------------------------- 1 | let fun cvt_num_neg_m cvt pos = 2 | cases `Num i => if pos then `Num i else `Neg (`Num i) 3 | | `Neg e => cvt (e, not pos) 4 | 5 | fun cvt_num_neg (e, pos) = 6 | match e with cvt_num_neg_m cvt_num_neg pos 7 | 8 | fun cvt_num_neg_plus_m cvt pos = 9 | cases `Plus (x, y) => `Plus (cvt (x, pos), cvt (y, pos)) 10 | default: cvt_num_neg_m cvt pos 11 | 12 | fun cvt_num_neg_plus (e, pos) = 13 | match e with cvt_num_neg_plus_m cvt_num_neg_plus pos 14 | in 0 15 | end 16 | -------------------------------------------------------------------------------- /Tests/neg2.mlpr: -------------------------------------------------------------------------------- 1 | let fun cvt_num_neg_m cvt pos = 2 | cases `Num i => if pos then `Num i else `Neg (`Num i) 3 | | `Neg e => cvt (e, not pos) 4 | 5 | fun cvt_plus_m cvt pos other = 6 | cases `Plus (x, y) => `Plus (cvt (x, pos), cvt (y, pos)) 7 | default: other 8 | 9 | fun cvt_minus_m cvt pos other = 10 | cases `Minus (x, y) => `Plus (cvt (x, pos), cvt (y, not pos)) 11 | default: other 12 | 13 | (* ---- *) 14 | 15 | fun cvt_num_neg (e, pos) = 16 | match e with cvt_num_neg_m cvt_num_neg pos 17 | 18 | fun cvt_num_neg_plus (e, pos) = 19 | match e with cvt_plus_m cvt_num_neg_plus pos 20 | (cvt_num_neg_m cvt_num_neg_plus pos) 21 | 22 | fun cvt_num_neg_plus_minus (e, pos) = 23 | match e with cvt_minus_m cvt_num_neg_plus_minus pos 24 | (cvt_plus_m cvt_num_neg_plus_minus pos 25 | (cvt_num_neg_m cvt_num_neg_plus_minus pos)) 26 | 27 | fun cvt_num_neg_minus (e, pos) = 28 | match e with cvt_minus_m cvt_num_neg_minus pos 29 | (cvt_num_neg_m cvt_num_neg_minus pos) 30 | in 0 31 | end 32 | -------------------------------------------------------------------------------- /Tests/person.mlpr: -------------------------------------------------------------------------------- 1 | let fun eq (s1, s2) = String.compare (s1, s2) == 0 2 | 3 | fun identify p = 4 | if eq (p.first, "Matthias") andalso eq (p.last, "Blume") then 5 | "that is me!\n" 6 | else String.concat ["a ", if p.male then "" else "fe", 7 | "male person named ", 8 | p.first, " ", p.last, " whose weight is ", 9 | String.fromInt p.weight, " pounds\n"] 10 | 11 | fun identify_twice p = 12 | String.concat [identify p, "and again: ", identify p] 13 | 14 | val matthias = { first = "Matthias", last = "Blume", 15 | weight = 180, male = true } 16 | val mayu = { first = "Mayu", last = "Shimizu", weight = 9, male = false, 17 | age = 0 } 18 | in String.output (identify matthias); 19 | String.output (identify_twice mayu); 20 | 0 21 | end 22 | -------------------------------------------------------------------------------- /Tests/poly-capture.mlpr: -------------------------------------------------------------------------------- 1 | let fun split { a, b, ... = r } = (a, b, r) 2 | val (a, b, r) = split { a = 1, b = 11, c = 22, d = 44, e = 5 } 3 | fun itos i = String.fromInt i 4 | in String.output (String.concat [itos a, " ", itos b, " ", 5 | itos r.c, " ", itos r.d, "\n"]); 6 | 0 7 | end 8 | -------------------------------------------------------------------------------- /Tests/poly-extend.mlpr: -------------------------------------------------------------------------------- 1 | let fun print l = String.output (String.concat l) 2 | fun extend r = { a = 1, ... = r, c = 2 } 3 | val { a, b, c, d } = extend { b = 3, d = 4 } 4 | fun i2s i = String.fromInt i 5 | in print [i2s a, " ", i2s b, " ", i2s c, " ", i2s d, "\n"]; 6 | 0 7 | end 8 | -------------------------------------------------------------------------------- /Tests/poly-replace.mlpr: -------------------------------------------------------------------------------- 1 | let fun print l = String.output (String.concat l) 2 | fun replace r = r where { a = 1, c = 2 } 3 | val { a, b, c, d } = replace { a = -1, b = 3, c = -2, d = 4 } 4 | fun i2s i = String.fromInt i 5 | in print [i2s a, " ", i2s b, " ", i2s c, " ", i2s d, "\n"]; 6 | 0 7 | end 8 | -------------------------------------------------------------------------------- /Tests/polyr.mlpr: -------------------------------------------------------------------------------- 1 | let fun bar (x, r) = 2 | if x < 0 then r.b 3 | else r.c 4 | 5 | fun length l = 6 | case l of 7 | [] => 0 8 | | _ :: t => 1 + length t 9 | 10 | fun foo r = r where {| a = 1 |} 11 | 12 | fun ignore _ = () 13 | 14 | fun f x = x 15 | in 16 | ignore (foo {| a = "hello", b = 1 |}); 17 | bar (length String.cmdline_args, { a = 10, b = 20, c = 30}) + 18 | bar (11, { c = f 22, b = f 4, d = 55, e = 1 }) 19 | end 20 | -------------------------------------------------------------------------------- /Tests/pr.mlpr: -------------------------------------------------------------------------------- 1 | let fun f (x) = 2 | x.f.b + x.d + x.f.a + x.f.c 3 | 4 | fun doit () = f { d = 1, f = { a = 10, b = 7, c = 22 } } 5 | 6 | val x = doit () 7 | 8 | in String.output (String.concat [String.fromInt x, "\n"]); 9 | 0 10 | end 11 | -------------------------------------------------------------------------------- /Tests/reverse.mlpr: -------------------------------------------------------------------------------- 1 | let fun reverse (x, y) = 2 | case x of 3 | [] => y 4 | | h :: t => reverse (t, h :: y) 5 | in String.output (String.concat (reverse ("\n" :: String.cmdline_args, []))); 6 | 0 7 | end 8 | -------------------------------------------------------------------------------- /Tests/scratch.mlpr: -------------------------------------------------------------------------------- 1 | let val n = {| i = 1000 |} 2 | fun withfresh f = let val i = n!i in n!i := i+1; f i end 3 | 4 | (* ---- utilities ---- *) 5 | 6 | fun Let (x, e1, e2) = `App (`Lam ([x], e2), [e1]) 7 | fun kv2kb kv = fn v => `App (kv, [v]) 8 | fun kb2kv kb = withfresh (fn rx => `Lam ([rx], kb (`Var rx))) 9 | 10 | fun cvt_app (e, el, kv) = 11 | let fun lc (el, kb) = 12 | case el of [] => kb [] 13 | | e :: el => pc (e, el, fn (v, vl) => kb (v :: vl)) 14 | and pc (e, el, kb) = cvt (e, fn v => lc (el, fn vl => kb (v, vl))) 15 | in pc (e, el, fn (v, vl) => `App (v, kv :: vl)) 16 | end 17 | 18 | and cvt_lam (xl, e) = 19 | withfresh (fn xk => `Lam (xk :: xl, tcvt (e, xk))) 20 | 21 | and cvt (e, kb) = match e with 22 | cases `Const i => kb (`Const i) 23 | | `Var x => kb (`Var x) 24 | | `Lam (xl, e) => kb (cvt_lam (xl, e)) 25 | | `App (e, el) => cvt_app (e, el, kb2kv kb) 26 | 27 | and tcvt (e, kx) = match e with 28 | cases `Const i => `App(`Var kx, [`Const i]) 29 | | `Var x => `App(`Var kx, [`Var x]) 30 | | `Lam (xl, e) => `App (`Var kx, [cvt_lam (xl, e)]) 31 | | `App (e, el) => cvt_app (e, el, `Var kx) 32 | 33 | fun convert e = cvt_lam ([], e) 34 | in 0 35 | end 36 | -------------------------------------------------------------------------------- /Tests/simpleexn.mlpr: -------------------------------------------------------------------------------- 1 | let fun f b = if b then raise `Fail () else f (not b) 2 | fun g b = 3 | try x = f b in x 4 | handling `Fail () => raise `Aborted () 5 | end 6 | in try x = g false in x 7 | handling `Fail () => 1 8 | end 9 | end 10 | -------------------------------------------------------------------------------- /Tests/singleton.mlpr: -------------------------------------------------------------------------------- 1 | let fun f () = { a = `Fun f } 2 | in 0 3 | end 4 | -------------------------------------------------------------------------------- /Tests/spill.mlpr: -------------------------------------------------------------------------------- 1 | let fun h (f, r) = 2 | let val x1 = f (r.1) 3 | val x2 = f (r.2) 4 | val x3 = f (r.3) 5 | val x4 = f (r.4) 6 | val x5 = f (r.5) 7 | val x6 = f (r.6) 8 | val x7 = f (r.7) 9 | val x8 = f (r.8) 10 | val x9 = f (r.9) 11 | val x10 = f (r.10) 12 | val x11 = f (r.11) 13 | val x12 = f (r.12) 14 | val x13 = f (r.13) 15 | val x14 = f (r.14) 16 | val x15 = f (r.15) 17 | val x16 = f (r.16) 18 | val x17 = f (r.17) 19 | val x18 = f (r.18) 20 | val x19 = f (r.19) 21 | val x20 = f (r.20) 22 | in x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + 23 | x11 + x12 + x13 + x14 + x15 + x16 + x17 + x18 + x19 + x20 24 | end 25 | 26 | fun g (f, r) = h (f, { 20 = 20, ... = r }) 27 | 28 | fun f x = x + 1 29 | 30 | val x = g (f, (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 31 | 11, 12, 13, 14, 15, 16, 17, 18, 19)) 32 | in String.output (String.concat [String.fromInt x, "\n"]); 33 | 0 34 | end 35 | -------------------------------------------------------------------------------- /Tests/tcall.mlpr: -------------------------------------------------------------------------------- 1 | let fun f (g, x) = (g x; g x) 2 | 3 | fun h s = String.output (String.concat [s, "\n"]) 4 | 5 | in f (h, "foo"); 6 | 0 7 | end 8 | -------------------------------------------------------------------------------- /Tests/twosel.mlpr: -------------------------------------------------------------------------------- 1 | let fun f x = x.person.name 2 | in 0 3 | end 4 | -------------------------------------------------------------------------------- /Tests/typcall.mlpr: -------------------------------------------------------------------------------- 1 | let fun f x = String.output (String.concat [x.g, x.b]) 2 | val g = f 3 | in g { a = true, b = "\n", c = 1, d = 2, e = 23, 4 | f = "foobar", g = "hello world", h = 1 }; 5 | 0 6 | end 7 | -------------------------------------------------------------------------------- /Tests2/bad-expr.mlpr: -------------------------------------------------------------------------------- 1 | let fun mkEval (c, e) = match e with c 2 | 3 | val _ = mkEval (cases `Var v => 0, `Var 0) 4 | in 5 | 0 6 | end 7 | -------------------------------------------------------------------------------- /Tests2/ex_pat.mlpr: -------------------------------------------------------------------------------- 1 | let (* library *) 2 | fun s2i x = String.toInt x 3 | fun i2s x = String.fromInt x 4 | fun print x = String.output (i2s x) 5 | fun println x = (String.output (i2s x); String.output ("\n")) 6 | 7 | fun assert (id, x, y) = 8 | if x == y 9 | then (String.output "#"; print id; String.output " is right."; String.output "\n") 10 | else (String.output "#"; print id; String.output " is wrong."; String.output "\n") 11 | 12 | 13 | 14 | (* test cases *) 15 | fun run () = ( 16 | (* basic *) 17 | assert (1, 18 | let fun f x = let val {x=a, y=b, ...=c} = x in a end 19 | in f {x=1, y=true, z=[]} end, 1); 20 | 21 | assert (2, 22 | let fun f x = let val {x=a, ...=c} = x in c end 23 | fun f' x = x.y 24 | in f' (f {x=true, y=5, z=[]} ) end, 5); 25 | 26 | assert (3, 27 | let fun f x = let val {x=a, ...=c} = x in a end 28 | fun g _ = f {x=1, y=true, z=[]} 29 | fun g' _ = f {x=true, z=[]} 30 | in g () end, 1); 31 | 32 | assert (4, 33 | let fun f x = let val {x=a, y=b, ...=c} = x in a end 34 | fun g _ = f {x=1, y=true, z=[]} 35 | fun g' _ = f {x=true, y=[], z=[]} 36 | in g () end, 1); 37 | 38 | assert (5, 39 | let fun f x = let val {x=a, ...=c} = x in a end 40 | fun g _ = f {x=1, y=true} 41 | in g () end, 1); 42 | assert (6, 43 | let fun f x = let val {x=a, ...=c} = x in c end (* SEL (r,1,3) *) 44 | fun g x = let val {y=a, ...=c} = f x in a end (* SEL (r,1,2) *) 45 | in g {x=true, y=5, z=[]} end, 5); 46 | 47 | assert (7, 48 | let fun g x = let val {y=a, ...=c} = {y=x.y, z=x.z} in a end 49 | in g {x=true, y=5, z=[]} end, 5); 50 | 51 | assert (8, 52 | let fun f x = let val {...=c} = x in c end (* SEL (r,0,3) *) 53 | fun g x = let val {x=_, y=a, ...=c} = f x in a end (* SEL (r,2,3) *) 54 | in g {x=true, y=5, z=[]} end, 5); 55 | 56 | assert (9, 57 | let fun f x = let val {x=a, ...=c} = x in c end 58 | fun g _ = let val {y=a, ...=c} = 59 | f {x=true, y=5, z=[]} in a end 60 | in g() end, 5); 61 | 62 | assert (10, 63 | let fun f {x=a, ...=c} = c (* SEL (r,1,3) *) 64 | fun g x = let val {y=a, ...=c} = f x in a end (* SEL (r,1,2) *) 65 | in g {x=true, y=5, z=[]} end, 5) 66 | ) 67 | 68 | in (run (); 0) 69 | end 70 | -------------------------------------------------------------------------------- /Tests2/ex_pat_simple.mlpr: -------------------------------------------------------------------------------- 1 | let fun i2s x = String.fromInt x 2 | fun print x = String.output (i2s x) 3 | fun assert (id, x, y) = 4 | if x == y 5 | then (String.output "#"; print id; String.output " is right."; String.output "\n") 6 | else (String.output "#"; print id; String.output " is wrong."; String.output "\n") 7 | 8 | fun f {x=a, ...=c} = c (* SEL (r,1,3) *) 9 | fun g x = let val {y=a, ...=c} = f x in a end (* SEL (r,1,2) *) 10 | in (assert (1, g {x=true, y=5, z=[]}, 5);0) 11 | end 12 | -------------------------------------------------------------------------------- /Tests2/ex_sub.mlpr: -------------------------------------------------------------------------------- 1 | (***********************************) 2 | (* where exp *) 3 | (***********************************) 4 | 5 | let (* basic library *) 6 | fun s2i x = String.toInt x 7 | fun i2s x = String.fromInt x 8 | fun print x = String.output (i2s x) 9 | fun println x = (String.output (i2s x); String.output ("\n")) 10 | 11 | fun assert (id, x, y) = 12 | if x == y 13 | then (String.output "#"; print id; String.output " is right."; String.output "\n") 14 | else (String.output "#"; print id; String.output " is wrong."; String.output "\n") 15 | 16 | (* utilities *) 17 | 18 | in 19 | assert (1, 20 | let fun f r = {c=5, ...=r} 21 | fun g s = 22 | let val {c, ...=r} = f s 23 | in {a=c, ...=r} 24 | end 25 | in (g {b=3}).a end, 5); 0 26 | end -------------------------------------------------------------------------------- /Tests2/ex_where.mlpr: -------------------------------------------------------------------------------- 1 | (***********************************) 2 | (* where exp *) 3 | (***********************************) 4 | 5 | let (* basic library *) 6 | fun s2i x = String.toInt x 7 | fun i2s x = String.fromInt x 8 | fun print x = String.output (i2s x) 9 | fun println x = (String.output (i2s x); String.output ("\n")) 10 | 11 | fun assert (id, x, y) = 12 | if x == y 13 | then (String.output "#"; print id; String.output " is right."; String.output "\n") 14 | else (String.output "#"; print id; String.output " is wrong."; String.output "\n") 15 | 16 | (* utilities *) 17 | 18 | (* test scripts *) 19 | fun run () = ( 20 | (* basic *) 21 | assert (1, 22 | let fun f r = r where {c=10} 23 | fun f' r = r.c 24 | fun g _ = f' (f {a=10, c=30}) 25 | in g () end, 10); 26 | 27 | assert (2, 28 | let fun f r = r where {c=10} 29 | fun f' r = r.c 30 | fun g _ = f' (f {a=10, b=20, c=30}) 31 | in g () end, 10); 32 | 33 | assert (3, 34 | let fun f r = r where {a=10} 35 | fun f' r = r.b 36 | fun g _ = f' ( f {a=0, b=20, c =30} ) 37 | fun g' _ = f'(f {a=20, b=30}) 38 | in g () end, 20); 39 | 40 | assert (4, 41 | let fun f r = r where {b=20} 42 | fun f' r = r.c 43 | fun g _ = f'(f {a=10, b=true, c=30}) 44 | fun g' _ = f'(f {b=0, c=5}) 45 | in g () end, 30); 46 | 47 | assert (5, 48 | let fun f r = r where {b=20, d=40} 49 | fun f' r = r.c 50 | fun g _ = f'(f {a=10, b=0, c=30, d=0}) 51 | fun g' _ = f'(f {b=true, c=5, d="Hello"}) 52 | in g () end, 30); 53 | 54 | (* flex record length /7,5,2/ *) 55 | assert (6, 56 | let fun f r = r 57 | fun f' r = r where {a=7} 58 | fun g r = let val r' = f' r in r'.a end 59 | in g (f {a=0, b=5, c=3}) end, 7); 60 | 61 | (* twisted - /10,20,30/ *) 62 | assert (7, 63 | let fun f r = r where {a=10} 64 | fun f' r = r.b 65 | fun g _ = let val c = f {a=0, b=20,c =30} in f' c end 66 | fun g' _ = f'(f {a=20, b=30}) 67 | in g () end, 20); 68 | 69 | (* twisted - /10,20,30/ *) 70 | assert (8, 71 | let fun f r = r where {a=10} 72 | fun f' r = r.b 73 | fun g r = let val c = f r in f' c end 74 | fun g' _ = f'(f {a=20, b=30}) 75 | in g {a=0, b=20, c=30} end, 20) 76 | 77 | ) 78 | 79 | in (run (); 0) 80 | end 81 | 82 | 83 | 84 | 85 | -------------------------------------------------------------------------------- /Tests2/ex_where_simple.mlpr: -------------------------------------------------------------------------------- 1 | let fun i2s x = String.fromInt x 2 | fun print x = String.output (i2s x) 3 | fun assert (id, x, y) = 4 | if x == y 5 | then (String.output "#"; print id; String.output " is right."; String.output "\n") 6 | else (String.output "#"; print id; String.output " is wrong."; String.output "\n") 7 | 8 | fun f r1 r2 = r1 where {a=7, c=r2.a} 9 | fun g r1 r2 = f r1 r2 10 | fun f' r = r.a 11 | 12 | in (assert(1, f' (g {a=0, c=4, d=5} {a=4}), 7); 0) 13 | end 14 | -------------------------------------------------------------------------------- /Tests2/ex_with.mlpr: -------------------------------------------------------------------------------- 1 | (***********************************) 2 | (* with exp *) 3 | (***********************************) 4 | 5 | let (* basic library *) 6 | fun s2i x = String.toInt x 7 | fun i2s x = String.fromInt x 8 | fun print x = String.output (i2s x) 9 | fun println x = (String.output (i2s x); String.output ("\n")) 10 | 11 | fun assert (id, x, y) = 12 | if x == y 13 | then (String.output "#"; print id; String.output " is right."; String.output "\n") 14 | else (String.output "#"; print id; String.output " is wrong."; String.output "\n") 15 | 16 | (* utilities *) 17 | 18 | (* test scripts *) 19 | fun run () = ( 20 | assert (1, 21 | let fun f r = {b=20, ...=r} 22 | fun f' r = r.b 23 | fun g _ = f {a=10, c=30} 24 | in f' (g ()) end, 20); 25 | 26 | assert (2, 27 | let fun f r = {D=4, ...=r.a} 28 | fun g _ = f {a={A=1,B=2,C=3}, c=30} 29 | fun g' r = r.B 30 | in g' (g ()) end, 2); 31 | 32 | assert (3, 33 | let fun f {a=x, ...} = {D=4, ...=x} 34 | fun g _ = f {a={A=1,B=2,C=3}, c=30} 35 | fun g' r = r.B 36 | in g' (g ()) end, 2); 37 | 38 | assert (4, 39 | let fun f r = {a=10, ...=r} 40 | fun f' r = r.b 41 | fun g _ = f'(f {b=20}) 42 | fun g' _ = f'(f {b=20, c=30}) 43 | in g () end, 20); 44 | 45 | assert (5, 46 | let fun f r = {b=20, ...=r} 47 | fun f' r = r.c 48 | fun g _ = f'(f {a=10, c=30}) 49 | fun g' _ = f'(f {c=5}) 50 | in g () end, 30); 51 | 52 | assert (6, 53 | let fun f r = {b=20, d=40, ...=r} 54 | fun f' r = r.c 55 | fun g _ = f'(f {a=10, c=30}) 56 | fun g' _ = f'(f {c=5}) 57 | in g () end, 30); 58 | 59 | (* flex record length /7,5,3/ *) 60 | assert (7, 61 | let fun f r = {a=7, ...=r} 62 | fun f' r = r.a 63 | fun g r = f' (f r) 64 | in g {b=5, c=3} end, 7) 65 | ) 66 | 67 | in (run (); 0) 68 | end 69 | -------------------------------------------------------------------------------- /Tests2/ex_with_simple_1.mlpr: -------------------------------------------------------------------------------- 1 | let fun i2s x = String.fromInt x 2 | fun print x = String.output (i2s x) 3 | fun assert (id, x, y) = 4 | if x == y 5 | then (String.output "#"; print id; String.output " is right."; String.output "\n") 6 | else (String.output "#"; print id; String.output " is wrong."; String.output "\n") 7 | 8 | fun f {x=a, ...=r} = {...=a, b=r.y} 9 | fun f' r = r.b 10 | 11 | in (assert (1, f' (f {x={a=1, c=3}, y=5}), 5); 0) 12 | end 13 | -------------------------------------------------------------------------------- /Tests2/ex_with_simple_2.mlpr: -------------------------------------------------------------------------------- 1 | let fun i2s x = String.fromInt x 2 | fun print x = String.output (i2s x) 3 | fun assert (id, x, y) = 4 | if x == y 5 | then (String.output "#"; print id; String.output " is right."; String.output "\n") 6 | else (String.output "#"; print id; String.output " is wrong."; String.output "\n") 7 | 8 | fun f r = {...=r, d=7} 9 | fun f' r = r.b 10 | fun g r = f' (f r) 11 | 12 | in (assert (1, g {a=1, b=3, c=5}, 3);0) 13 | end 14 | -------------------------------------------------------------------------------- /Tests2/recsub.mlpr: -------------------------------------------------------------------------------- 1 | (* record subtraction *) 2 | 3 | let (* library *) 4 | val fromInt = String.fromInt 5 | val toInt = String.toInt 6 | val output = String.output 7 | val outputln = fn x => output (String.concat[x, "
"]) 8 | 9 | fun outputlist ls = 10 | case ls of 11 | [] => outputln "" 12 | | hd :: tl => (output hd; output " "; outputlist tl) 13 | 14 | (* getDriver function extends a record 15 | * with {vender:string, year:int} *) 16 | fun getDriver person = {vender="Toyota", year=1996, ... = person} 17 | 18 | (* by using record subtraction and extension, 19 | * field rename from vender to makercan be obtained *) 20 | fun getDriver2 person = 21 | let val {vender=a, ... = r} = getDriver person 22 | in 23 | {maker=a, ... = r} 24 | end 25 | 26 | fun print r = outputlist ["driver = ", r.name, 27 | ", age = ", fromInt r.age, 28 | ", vender = ", r.vender, 29 | ", year = ", fromInt r.year] 30 | 31 | fun print2 r = outputlist ["driver = ", r.name, 32 | ", age = ", fromInt r.age, 33 | ", maker = ", r.maker, 34 | ", year = ", fromInt r.year] 35 | 36 | in 37 | print (getDriver {age=25, name="Jones", married=true}); 38 | print2 (getDriver2 {age=25, name="Jones", married=true}); 39 | 0 40 | end 41 | 42 | -------------------------------------------------------------------------------- /Tests2/run.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | for i in `ls *.mlpr` 4 | do 5 | echo "testing $i" 6 | NAME=`echo "$i" | sed 's/.mlpr//g'` 7 | cd .. 8 | echo "*** compile $i" 9 | sml @SMLload=mlpolyr Tests2/$i 10 | echo "*** run $NAME" 11 | Tests2/$NAME 12 | echo "*** end of $NAME" 13 | echo "" 14 | cd Tests2 15 | done 16 | -------------------------------------------------------------------------------- /Tests2/simple.mlpr: -------------------------------------------------------------------------------- 1 | let fun i2s x = String.fromInt x 2 | fun print x = String.output (i2s x) 3 | fun assert (id, x, y) = 4 | if x == y 5 | then (String.output "#"; print id; String.output " is right."; String.output "\n") 6 | else (String.output "#"; print id; String.output " is wrong."; String.output "\n") 7 | 8 | fun f x = let val {x=a, y=b, ... = c} = x in a end 9 | 10 | in (assert (1, f {x=1, y=true, z=[]}, 1); 0) 11 | end 12 | -------------------------------------------------------------------------------- /Tests2/test_pattern_with_case.mlpr: -------------------------------------------------------------------------------- 1 | let (* basic library *) 2 | fun print x = (String.output (String.fromInt x)) 3 | fun println x = (String.output (String.fromInt x); String.output ("\n")) 4 | fun assert (id, x, y) = 5 | if x == y 6 | then (String.output "#"; print id; String.output " is right."; String.output "\n") 7 | else (String.output "#"; print id; String.output " is wrong."; String.output "\n") 8 | 9 | fun s2i x = String.toInt x 10 | fun i2s x = String.fromInt x 11 | fun pnum x = (String.output (i2s x); String.output ("\n")) 12 | 13 | (* testcase 1 *) 14 | fun sumpair l = 15 | case l of 16 | [] => 0 17 | | (_,y) :: t => y + sumpair t 18 | 19 | fun makepair l = 20 | case l of 21 | [] => [(0,0)] 22 | | h :: t => 23 | (h, h) :: makepair t 24 | 25 | (* test case 2 *) 26 | fun sumrec l = 27 | case l of 28 | [] => 0 29 | | {x=a, y=_} :: t => 30 | a + sumrec t 31 | 32 | fun makerec l = 33 | case l of 34 | [] => [{x=0, y=0}] 35 | | h :: t => 36 | {x= h, y = h} :: makerec t 37 | 38 | (* test case 3 *) 39 | fun calc l = 40 | case l of 41 | [] => 0 42 | | (_,{x=_,y=(a,b)},z) :: t => a + calc t 43 | 44 | fun build l = 45 | case l of 46 | [] => [(0,{x=0,y=(0,0)},0)] 47 | | h :: t => (h,{x=h*1,y=(h*2,h*3)},h*4) :: build t 48 | 49 | fun run _ = ( 50 | (* simple tuple case *) 51 | assert (1, sumpair (makepair [1,2,3]), 6); 52 | 53 | (* simple record case *) 54 | assert (2, sumrec (makerec [1,2,3]), 6); 55 | 56 | (* nested case *) 57 | assert (3, calc (build [1,2,3]), 12) 58 | ) 59 | 60 | in (run ();0) 61 | end 62 | -------------------------------------------------------------------------------- /Tests2/test_pattern_with_let.mlpr: -------------------------------------------------------------------------------- 1 | let (* basic library *) 2 | fun print x = (String.output (String.fromInt x)) 3 | fun println x = (String.output (String.fromInt x); String.output ("\n")) 4 | fun assert (id, x, y) = 5 | if x == y 6 | then (String.output "#"; print id; String.output " is right."; String.output "\n") 7 | else (String.output "#"; print id; String.output " is wrong."; String.output "\n") 8 | 9 | (* utility function *) 10 | fun f (x, y, z) = (x, y, z) 11 | fun f' (x, y, z) = {x=x, y=y, z=z} 12 | fun f'' (x, y, z) = (x, y+z) 13 | fun f''' (x, y, z) = (x, {x=y,y=y},z) 14 | fun g (x, y, z) = x + y + z 15 | fun g' (x, y, z) = (x + y, y) 16 | 17 | fun run _ = ( 18 | (* normal case *) 19 | assert (1, let val (p1, p2, p3) = f(1, 2, 3) in p2 end, 2); (* ans : 2 *) 20 | 21 | (* record *) 22 | assert (2, let val {x=_, y=b, z=c} = f'(1, 2, 3) in b end, 2); (* and : 2 *) 23 | 24 | assert (3, let val {x=_, y=b, z=c} = f'(1, 2, 3) in b end, 2); (* ans : 2 *) 25 | 26 | (* simple case / w/o nested case *) 27 | assert (4, let val (p1,p2,p3) = (1,2,3) in p2 end, 2); (* ans : 2 *) 28 | assert (5, let val (p1,p2,p3) = f(1,2,3) in p2 end, 2); (* ans : 2 *) 29 | assert (6, let val (p1,_,p3) = (1,2,3) in p3 end, 3); (* ans : 3 *) 30 | assert (7, let val {x=a, y=b, z=c} = {x=1, y=2, z=3} in b end, 2); (* ans : 2 *) 31 | assert (8, let val {x=a, y=b, z=c} = f'(1,2,3) in b end, 2); (* ans : 2 *) 32 | assert (9, let val {x = a, y = b, z = c} = {x=1, y=2, z=3} in g (a, b, c) end, 6); (* ans : 6 *) 33 | assert (10, let val {x = a, y = b, z = c} = f'(1,2,3) in g (a, b, c) end, 6); (* ans : 6 *) 34 | 35 | (* nested case *) 36 | assert (11, let val (p1,{x=p21,y=p22},p3) = (1,{x=2,y=2},3) in p1+p21 end, 3); (* ans : 3 *) 37 | assert (12, let val {x = a, y = b, z = c} = {x=1,y={x=2,y=2},z=3} in g (a, c, 3) end, 7); (* ans : 7 *) 38 | assert (13, let val {x = a, y = b, z = c} = {x = 1, y = (1,2), z = 3} in g (a, c, 3) end, 7); (* ans : 7 *) 39 | assert (14, let val {x=p1,y1=p21,y2=p22,z=z} = {x=1,y1=2,y2=2,z=3} in p21 end, 2); (* ans : 2 *) 40 | assert (15, let val (p1,(p21,_),p3) = (1,(2,2),3) in p1+p21 end, 3); (* ans : 3 *) 41 | assert (16, let val (p1,(p21,p22),p3) = (1,(2,2),3) in p1+p21 end, 3) (* ans : 3 *) 42 | ) 43 | 44 | (* type error *) 45 | (* 46 | fun error1 (x,y,z) = 47 | let {x=a,y=b} = {x=x,z=z} in a (* error : type mismatch *) 48 | 49 | fun error2 (x,y,z) = 50 | let (p1,_,p3) = (x,y,z) in p2 (* unbound : p2 *) 51 | 52 | fun error3 (x,y,z) = 53 | let (p1, p2, p3) = (1,2) in g (p1, p2, p3) (* error : missing or extra *) 54 | 55 | fun error4 (x,y,z) = 56 | let (p1, p2, p3) = f'' (1,2, 3) in g (p1, p2, p3) (* error : missing or extra *) 57 | 58 | fun error5 (x,y,z) = 59 | let {x = a, y = b} = f'(x, y, z) in g (a, b, 3) (* error : missing or extra *) 60 | *) 61 | 62 | in (run ();0) 63 | end 64 | -------------------------------------------------------------------------------- /Tests2/test_pattern_with_pri.mlpr: -------------------------------------------------------------------------------- 1 | let (* basic library *) 2 | fun print x = (String.output (String.fromInt x)) 3 | fun println x = (String.output (String.fromInt x); String.output ("\n")) 4 | fun assert (id, x, y) = 5 | if x == y 6 | then (String.output "#"; print id; String.output " is right."; String.output "\n") 7 | else (String.output "#"; print id; String.output " is wrong."; String.output "\n") 8 | 9 | fun s2i x = String.toInt x 10 | fun i2s x = String.fromInt x 11 | fun pnum x = (String.output (i2s x); String.output ("\n")) 12 | 13 | (* test case 0 - original *) 14 | fun test0 x = 15 | let val a = let fun f x = x.x in f end 16 | in a x 17 | end 18 | 19 | (* test case 1 - simle case / tuple *) 20 | fun test1 x = 21 | let val (a,b) = (let fun f x = x.x in f end, let fun g x = x.y in g end) 22 | in a x + b x 23 | end 24 | 25 | (* test case 2 - nested case / tuple *) 26 | fun test2 x = 27 | let val ((a,b),c) = ((let fun f x = x.x in f end, let fun g x = x.y in g end), 28 | let fun i x = x.z in i end) 29 | in a x + b x + c x 30 | end 31 | 32 | (* test case 3 - redundant case / tuple *) 33 | fun test3 x = 34 | let val (a,b) = (let fun f x = x.x in f end, let fun g x = 5 in g end) 35 | in a x + b x 36 | end 37 | 38 | fun run _ = ( 39 | (* original case *) 40 | assert (0, test0 {x=1, y="hello"}, 1); 41 | 42 | (* simple case *) 43 | assert (1, test1 {x=1, y=2}, 3); 44 | 45 | (* nested case *) 46 | assert (2, test2 {x=1, y=2, z=3}, 6); 47 | 48 | (* redundant case *) 49 | assert (3, test3 {x=1, y=2, z=3}, 6) 50 | ) 51 | 52 | in (run (); 0) 53 | end 54 | 55 | 56 | -------------------------------------------------------------------------------- /Tests2/test_pattern_with_pri_simple.mlpr: -------------------------------------------------------------------------------- 1 | let fun i2s x = String.fromInt x 2 | fun print x = String.output (i2s x) 3 | fun assert (id, x, y) = 4 | if x == y 5 | then (String.output "#"; print id; String.output " is right."; String.output "\n") 6 | else (String.output "#"; print id; String.output " is wrong."; String.output "\n") 7 | 8 | val (a, b) = 9 | (let fun f x = x.x in f end, 10 | let fun g x = x.y in g end) 11 | 12 | in (assert (1, a {x=3, y="hello"} + b {x="hello", y=2}, 5); 0) 13 | end 14 | -------------------------------------------------------------------------------- /Tests2/test_pattern_with_wild.mlpr: -------------------------------------------------------------------------------- 1 | let (* basic library *) 2 | 3 | fun print x = (String.output (String.fromInt x)) 4 | fun println x = (String.output (String.fromInt x); String.output ("\n")) 5 | fun assert (id, x, y) = 6 | if x == y 7 | then (String.output "#"; print id; String.output " is right."; String.output "\n") 8 | else (String.output "#"; print id; String.output " is wrong."; String.output "\n") 9 | 10 | (* utility function *) 11 | fun f (x, y, z) = (x, y, z) 12 | fun f' (x, y, z) = {x=x, y=y, z=z} 13 | fun f'' (x, y, z) = (x, y+z) 14 | fun f''' (x, y, z) = (x, {x=y,y=y},z) 15 | fun g (x, y, z) = x + y + z 16 | fun g' (x, y, z) = (x + y, y) 17 | 18 | (* main test *) 19 | fun run _ = ( 20 | assert (1, let val {x=a, ...=_} = {x=1, y=2, z=3} in a end, 1); (* ans : 1 *) 21 | 22 | assert (2, let val {x=a, ...=c} = {x=1, y=2, z=2} in c.z end, 2); (* ans : 2 *) 23 | 24 | assert (3, let val {x=a, ...=c} = 25 | {x=1, y=let fun f y=y.x in f end, z=3} in c.y {x=2} end, 2); (* ans : 2 *) 26 | 27 | (* record *) 28 | assert (4, 1, 1); (* for filling empty test case *) 29 | assert (5, let val {x=_, y=b, z=c} = f'(1,2,3) in b end, 2); (* ans : 2 *) 30 | assert (6, let val {x=_, y=b, z=c} = f'(1,2,3) in b end, 2); (* ans : 2 *) 31 | assert (7, let val {x=_, y=b, z=c} = f'(1,2,3) in b end, 2); (* ans : 2 *) 32 | 33 | (* simple case / w/o nested case *) 34 | assert (8, let fun tmp (x,y,z) = 35 | let val (p1,p2,p3) = (x,y,z) in p2 end (* ans : 2 *) 36 | in tmp (1,2,3) end, 2); 37 | 38 | assert (9, let fun tmp (x,y,z) = 39 | let val (p1,p2,p3) = f(x,y,z) in p2 end (* ans : 2 *) 40 | in tmp (1,2,3) end, 2); 41 | 42 | assert (10, let fun tmp (x,y,z) = 43 | let val (p1,_,p3) = (x,y,z) in p3 end (* ans : 3 *) 44 | in tmp (1,2,3) end, 3); 45 | 46 | assert (11, let fun tmp (x,y,z) = 47 | let val {x=a, y=b, z=c} = {x=x, y=y, z=z} in b end (* ans : 2 *) 48 | in tmp (1,2,3) end, 2); 49 | 50 | assert (12, let fun tmp (x,y,z) = 51 | let val {x=a, y=b, z=c} = f'(x,y,z) in b end (* ans : 2 *) 52 | in tmp (1,2,3) end, 2); 53 | 54 | assert (13, let fun tmp (x,y,z) = 55 | let val {x = a, y = b, z = c} = {x = x, y = y, z = z} in g (a, b, 3) end 56 | (* ans : 6 *) 57 | in tmp (1,2,3) end, 6); 58 | 59 | assert (14, let fun tmp (x,y,z) = 60 | let val {x = a, y = b, z = c} = f'(x, y, z) in g (a, b, c) end (* ans : 6 *) 61 | in tmp (1,2,3) end, 6); 62 | 63 | (* nested case *) 64 | assert (15, let fun tmp (x,y,z) = 65 | let val (p1,{x=p21,y=p22},p3) = (x,{x=y,y=y},z) in p1+p21 end (* ans : 3 *) 66 | in tmp (1,2,3) end, 3); 67 | 68 | assert (16, let fun tmp (x,y,z) = 69 | let val {x = a, y = b, z = c} = {x = x, y = {x=1,y=2}, z = z} in g (a, z, 3)end 70 | (* ans : 7 *) 71 | in tmp (1,2,3) end, 7); 72 | 73 | assert (17, let fun tmp (x,y,z) = 74 | let val {x = a, y = b, z = c} = {x = x, y = (1,2), z = z} in g (a, z, 3) end 75 | (* ans : 7 *) 76 | in tmp (1,2,3) end, 7); 77 | 78 | assert (18, let fun tmp (x,y,z) = 79 | let val {x=p1,y1=p21,y2=p22,z=z} = {x=x,y1=y,y2=y,z=z} in p21 end (* ans : 2 *) 80 | in tmp (1,2,3) end, 2); 81 | 82 | assert (19, let fun tmp (x,y,z) = 83 | let val (p1,(p21,_),p3) = (x,(y,y),z) in p1+p21 end (* ans : 3 *) 84 | in tmp (1,2,3) end, 3); 85 | 86 | assert (20, let fun tmp (x,y,z) = 87 | let val (p1,(p21,p22),p3) = (x,(y,y),z) in p1+p21 end (* ans : 3 *) 88 | in tmp (1,2,3) end, 3) 89 | ) 90 | 91 | (* type error *) 92 | (* 93 | fun error1 (x,y,z) = 94 | let {x=a,y=b} = {x=x,z=z} in a (* error : type mismatch *) 95 | 96 | fun error2 (x,y,z) = 97 | let (p1,_,p3) = (x,y,z) in p2 (* unbound : p2 *) 98 | 99 | fun error3 (x,y,z) = 100 | let (p1, p2, p3) = (1,2) in g (p1, p2, p3) (* error : missing or extra *) 101 | 102 | fun error4 (x,y,z) = 103 | let (p1, p2, p3) = f'' (1,2, 3) in g (p1, p2, p3) (* error : missing or extra *) 104 | 105 | fun error5 (x,y,z) = 106 | let {x = a, y = b} = f'(x, y, z) in g (a, b, 3) (* error : missing or extra *) 107 | *) 108 | 109 | in (run ();0) 110 | end 111 | -------------------------------------------------------------------------------- /absyn.sml: -------------------------------------------------------------------------------- 1 | (* absyn.sml 2 | * 3 | * MLPolyR Abstract Syntax (AST with type information). 4 | * 5 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | structure Absyn = struct 8 | 9 | type symbol = Ast.symbol 10 | type integer = LiteralData.integer 11 | type typ = Types.typ 12 | type rtyp = Types.rtyp 13 | type prepolytype = Types.prepolytype 14 | type binop = Ast.binop 15 | type uop = Ast.uop 16 | type region = Ast.region 17 | 18 | datatype exp = 19 | LETexp of (def * Types.depth) list * exp 20 | | IFexp of exp * exp * exp * typ 21 | | LCASEexp of exp * exp * pat * pat * exp * typ 22 | | WHEREexp of Purity.purity * exp * typ * exp field list * typ 23 | | BINOPexp of binop * exp * exp * typ 24 | | UOPexp of uop * exp * typ 25 | | APPexp of exp * exp * typ 26 | | ASSIGNexp of exp * typ * RecordLabel.label * exp 27 | | SELexp of Purity.purity * exp * typ * RecordLabel.label * typ 28 | | BOOLexp of bool 29 | | NUMBERexp of integer 30 | | STRINGexp of string 31 | | UNITexp 32 | | VARexp of symbol * typ * Types.pri (* after generalization *) 33 | | SEQexp of exp * exp 34 | | LISTexp of exp list * typ 35 | | RECORDexp of Purity.purity * exp field list * 36 | (exp * typ * exp field list) option * typ 37 | | CONexp of exp field * typ 38 | | SWIDENexp of exp * typ * RecordLabel.label * typ 39 | | PSCASEexp of exp * exp * typ 40 | | FNexp of pat * exp * typ 41 | | RAISEexp of exp * typ (* type is "result" type *) 42 | | TRYexp of { scrutinee: exp, ert: rtyp, 43 | success: pat * exp, 44 | handling: (RecordLabel.label * pat * exp) list, 45 | rehandling: (RecordLabel.label * pat * exp) list, 46 | catchall: (pat * exp) option } 47 | | MARKexp of exp * region 48 | 49 | and def = 50 | VALdef of pat * Symbol.Set.set * exp 51 | | FUNdef of function list * Types.pri (* before gen. *) * reccases list 52 | 53 | and pat' = 54 | WILDpat 55 | | VARpat of symbol 56 | | RECORDpat of Purity.purity * pat field list * pat option * Types.pri 57 | | ANDpat of pat' * pat' 58 | | MARKpat of pat' * region 59 | 60 | withtype 'a field = RecordLabel.label * 'a 61 | 62 | and pat = pat' * prepolytype 63 | 64 | and function = { f: symbol, params: pat list, body: exp } 65 | 66 | and reccases = { c: symbol, ct: typ, rhs: exp } 67 | 68 | and rule = pat field * exp 69 | 70 | type program = exp 71 | 72 | fun TUPLEexp (el, t) = 73 | let fun loop ([], _, rfl) = RECORDexp (Purity.Pure, rev rfl, NONE, t) 74 | | loop (e :: es, i, rfl) = 75 | loop (es, i+1, (RecordLabel.NUMlab i, e) :: rfl) 76 | in loop (el, 1, []) 77 | end 78 | end 79 | -------------------------------------------------------------------------------- /anf-interpreter.sml: -------------------------------------------------------------------------------- 1 | (* anf-interpreter.sml 2 | * 3 | * A simple meta-circular interpreter for MLPolyR's 4 | * ANF intermediate language. 5 | * 6 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 7 | *) 8 | structure ANFInterpreter : sig 9 | 10 | datatype value = 11 | INTv of LiteralData.integer 12 | | RECv of recfields 13 | | FUNv of cont -> value list -> value list 14 | withtype recfields = value ref list 15 | and cont = value list -> value list 16 | 17 | val eval : (Label.label -> value) -> ANF.exp -> value list 18 | 19 | end = struct 20 | 21 | structure A = ANF 22 | 23 | datatype value = 24 | INTv of LiteralData.integer 25 | | RECv of recfields 26 | | FUNv of cont -> value list -> value list 27 | withtype recfields = value ref list 28 | and cont = value list -> value list 29 | 30 | fun vINT (INTv i) = i 31 | | vINT _ = raise Fail "integer required" 32 | fun vREC (RECv xrl) = xrl 33 | | vREC _ = raise Fail "record required" 34 | fun vFUN (FUNv f) = f 35 | | vFUN _ = raise Fail "function required" 36 | 37 | fun tuple xl = RECv (map ref xl) 38 | 39 | fun bind (v: LVar.lvar, x, env) v' = if v = v' then x else env v' 40 | 41 | fun bindl (vl, xl, env) = ListPair.foldl bind env (vl, xl) 42 | 43 | fun recidx i = LiteralData.toInt (i div MachSpec.wordSize) 44 | 45 | fun eval labenv e = 46 | let fun value env (A.VAR v) = env v 47 | | value _ (A.LABEL l) = labenv l 48 | | value _ (A.INT i) = INTv i 49 | fun apply ((x, xl), env, k) = 50 | vFUN (value env x) k (map (value env) xl) 51 | fun exp (A.VALUES xl, env, k) = 52 | k (map (value env) xl) 53 | | exp (A.BIND (v, x, e), env, k) = 54 | exp (e, bind (v, value env x, env), k) 55 | | exp (A.CALL (_, vl, a, e), env, k) = 56 | apply (a, env, fn xl => exp (e, bindl (vl, xl, env), k)) 57 | | exp (A.FIX (fl, e), env, k) = 58 | let fun env' v0 = 59 | case List.find (fn f => #1 (#f f) = v0) fl of 60 | SOME { f = (f, vl, e), ... } => 61 | FUNv (fn k' => fn xl => 62 | exp (e, bindl (vl, xl, env'), k')) 63 | | NONE => env v0 64 | in exp (e, env', k) 65 | end 66 | | exp (A.ARITH (aop, x, y, v, e), env, k) = 67 | exp (e, bind (v, INTv (Oper.doarith (aop, 68 | vINT (value env x), 69 | vINT (value env y))), 70 | env), 71 | k) 72 | | exp (A.RECORD (_, _, sl, v, e), env, k) = 73 | let fun build [] = [] 74 | | build (A.SGT x :: sl) = value env x :: build sl 75 | | build (A.SEQ { base, start, stop } :: sl) = 76 | let val br = vREC (value env base) 77 | val s = vINT (value env start) 78 | val e = vINT (value env stop) 79 | fun grow i = 80 | if i >= e then build sl 81 | else !(List.nth (br, recidx i)) :: 82 | grow (i+MachSpec.wordSize) 83 | in grow s 84 | end 85 | in exp (e, bind (v, tuple (build sl), env), k) 86 | end 87 | | exp (A.SELECT (x, y, _, v, e), env, k) = 88 | exp (e, bind (v, !(List.nth (vREC (value env x), 89 | recidx (vINT (value env y)))), 90 | env), 91 | k) 92 | | exp (A.UPDATE (x, y, z, e), env, k) = 93 | (List.nth (vREC (value env x), recidx (vINT (value env y))) 94 | := value env z; 95 | exp (e, env, k)) 96 | | exp (A.CMP (cop, x, y, et, ee), env, k) = 97 | if Oper.docmp (cop, vINT (value env x), vINT (value env y)) 98 | then exp (et, env, k) 99 | else exp (ee, env, k) 100 | | exp (A.JUMP (_, a), env, k) = 101 | apply (a, env, k) 102 | | exp (A.GETSP (v, e), env, k) = 103 | exp (e, bind (v, FUNv (fn _ => k), env), k) 104 | | exp (A.SETSP (x, e), env, k) = 105 | exp (e, env, vFUN (value env x) k) 106 | | exp (A.MAYJUMP (_, e), env, k) = 107 | exp (e, env, k) 108 | in exp (e, fn _ => raise Fail "unbound variable", fn xl => xl) 109 | end 110 | end 111 | -------------------------------------------------------------------------------- /anf.sml: -------------------------------------------------------------------------------- 1 | (* anf.sml 2 | * 3 | * The ANF intermediate language of the MLPolyR compiler. 4 | * (ANF = Lambda Calculus in A-Normal Form) 5 | * 6 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 7 | *) 8 | structure ANF = struct 9 | 10 | type lvar = LVar.lvar 11 | 12 | datatype value = datatype Lambda.value 13 | 14 | datatype exp = 15 | VALUES of value list 16 | | BIND of lvar * value * exp 17 | | CALL of Purity.purity * lvar list * app * exp 18 | | FIX of function list * exp 19 | | ARITH of Oper.arithop * value * value * lvar * exp 20 | | RECORD of Purity.purity * value * slice list * lvar * exp 21 | | SELECT of value * value * Purity.purity * lvar * exp 22 | | UPDATE of value * value * value * exp 23 | | CMP of Oper.cmpop * value * value * exp * exp 24 | | JUMP of Purity.purity * app 25 | | GETSP of lvar * exp 26 | | SETSP of value * exp 27 | | MAYJUMP of lvar * exp 28 | and slice = 29 | SGT of value 30 | | SEQ of { base: value, start: value, stop: value } 31 | withtype function = { f : lvar * lvar list * exp, inl: bool, hdlr: bool } 32 | and app = value * value list 33 | end 34 | -------------------------------------------------------------------------------- /asm.sml: -------------------------------------------------------------------------------- 1 | (* asm.sml 2 | * 3 | * Generic machine instruction. 4 | * This module is based on Andrew Appel's book 5 | * "Modern Compiler Implementation in ML" 6 | * 7 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 8 | *) 9 | structure Asm = struct 10 | 11 | type reg = string 12 | type temp = LVar.lvar 13 | type label = Label.label 14 | 15 | datatype jumpinfo = 16 | RETURN (* instruction ends current function *) 17 | | JUMP of label list (* instruction jumps to one of the labels *) 18 | | NOJUMP (* instruction falls through (no jump) *) 19 | 20 | datatype instr = 21 | OPER of { asm : string, (* template string *) 22 | dst : temp list, (* all temps defined by this operation *) 23 | src : temp list, (* all temps used by this operation *) 24 | jmp : jumpinfo } 25 | | LABEL of label 26 | | MOVE of { asm : string, (* template string *) 27 | dst : temp, (* destination of move *) 28 | src : temp } (* source of move *) 29 | | REGSAVE (* runs AFTER the stack frame has been created *) 30 | | REGRESTORE (* runs BEFORE the stack frame has been deleted *) 31 | | NOSTACK (* marks point where stack is not usable *) 32 | 33 | (* The template string must refer to source temps 34 | * using the `sN syntax (where N is the position of 35 | * the temp in the src list of OPER or 0 in the case of MOVE). 36 | * Numbering is 0-based: the first source temp is `s0, the second `s1 37 | * and so on. 38 | * Likewise, destination temps must be referred to using `dN. 39 | * For convenience, in the case of OPER one can refer to a label 40 | * name that appears in the jump info using `jN. 41 | * 42 | * Given a function for mapping temps to the name (a string) of 43 | * their respective machine register, the following function 44 | * formats instructions for output in an assembly code file: *) 45 | fun format (saytemp, regsave, regrestore) = let 46 | val oz = Char.ord #"0" 47 | fun dig c = Char.ord c - oz 48 | fun nth (l, c) = List.nth (l, dig c) 49 | val saylab = Label.escname 50 | fun out (asm, dst, src, jmp) = let 51 | fun elem (#"s", i) = saytemp (nth (src, i)) 52 | | elem (#"d", i) = saytemp (nth (dst, i)) 53 | | elem (#"j", i) = saylab (nth (jmp, i)) 54 | | elem _ = ErrorMsg.impossible "Asm: bad Asm format" 55 | fun f (#"`" :: l :: i :: rest) = 56 | String.explode (elem (l, i)) @ f rest 57 | | f (c :: rest) = c :: f rest 58 | | f [] = [] 59 | in 60 | String.implode (f (explode asm)) 61 | end 62 | in fn OPER { asm, dst, src, jmp } => 63 | let val ll = case jmp of JUMP ll => ll | _ => [] 64 | in ["\t" ^ out (asm, dst, src, ll)] 65 | end 66 | | LABEL lab => 67 | [saylab lab ^ ":"] 68 | | MOVE { asm, dst, src } => 69 | ["\t" ^ out (asm, [dst], [src], [])] 70 | | REGSAVE => regsave 71 | | REGRESTORE => regrestore 72 | | NOSTACK => ["\t; nostack"] 73 | end 74 | 75 | end 76 | -------------------------------------------------------------------------------- /ast.sml: -------------------------------------------------------------------------------- 1 | (* ast.sml 2 | * 3 | * MLPolyR's Abstract Syntax Trees. 4 | * 5 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | structure Ast = struct 8 | 9 | type symbol = Symbol.atom 10 | type integer = LiteralData.integer 11 | type cmpop = Oper.cmpop 12 | type arithop = Oper.arithop 13 | 14 | type pos = int 15 | type region = pos * pos 16 | 17 | type mlabel = RecordLabel.label * region (* marked label *) 18 | 19 | datatype boolconn = 20 | ANDALSO 21 | | ORELSE 22 | 23 | datatype binop = 24 | BOOLCONN of boolconn 25 | | CMP of cmpop 26 | | ARITH of arithop 27 | | CONS 28 | 29 | datatype uop = 30 | UMINUS 31 | | ISNULL 32 | | NOT 33 | 34 | datatype exp = 35 | LETexp of def list * exp 36 | | IFexp of exp * exp * exp 37 | | CASEexp of exp * dtmatch 38 | | WHEREexp of Purity.purity * exp * exp field list 39 | | BINOPexp of binop * exp * exp 40 | | UOPexp of uop * exp 41 | | APPexp of exp * exp 42 | | ASSIGNexp of exp * mlabel * exp 43 | | SELexp of Purity.purity * exp * mlabel 44 | | BOOLexp of bool 45 | | NUMBERexp of integer 46 | | STRINGexp of string 47 | | VARexp of symbol 48 | | SEQexp of exp list 49 | | LISTexp of exp list 50 | | RECORDexp of Purity.purity * exp field list 51 | | TUPLEexp of exp list 52 | | MATCHexp of mrule list * exp option 53 | | CONexp of mlabel * exp 54 | | SWIDENexp of exp * mlabel 55 | | PSCASEexp of exp * exp (* polymorphic sum case *) 56 | | FNexp of lambda 57 | | RAISEexp of exp 58 | | TRYexp of { scrutinee: exp, success: lambda, 59 | handling: mrule list, 60 | rehandling: mrule list, 61 | (* nothandling: mlabel list, 62 | * -- rely on encoding via catchall, widen, and raise *) 63 | catchall: lambda option } 64 | | MARKexp of exp * region 65 | 66 | and def = 67 | VALdef of pat * exp 68 | | FUNdef of function list * reccases list * region 69 | 70 | and function = FUN of symbol * pat list * exp * region 71 | 72 | and reccases = RC of symbol * exp * region 73 | 74 | and pat = 75 | WILDpat 76 | | VARpat of symbol 77 | | TUPLEpat of pat list 78 | | RECORDpat of Purity.purity * pat field list 79 | | MATCHpat of pat field list 80 | | ANDpat of pat * pat 81 | | MARKpat of pat * region 82 | 83 | withtype 'a field = (* NONE means "..." *) 84 | mlabel option * 'a 85 | 86 | and lambda = pat * exp 87 | 88 | and dtmatch = { nilcase: exp, conscase: pat * pat * exp } 89 | 90 | and mrule = mlabel * lambda * region 91 | 92 | type program = exp * region 93 | 94 | fun isSynVal (LETexp (dl, e)) = List.all isSynDef dl andalso isSynVal e 95 | | isSynVal (IFexp (e, e', e'')) = 96 | isSynVal e andalso isSynVal e' andalso isSynVal e'' 97 | | isSynVal (WHEREexp (Purity.Pure, e, fl)) = 98 | isSynVal e andalso List.all isSynField fl 99 | | isSynVal (WHEREexp (Purity.Impure, _, _)) = false 100 | | isSynVal (BINOPexp (BOOLCONN _, e, e')) = isSynVal e andalso isSynVal e' 101 | | isSynVal (BINOPexp (CMP _, e, e')) = isSynVal e andalso isSynVal e' 102 | | isSynVal (BINOPexp (ARITH _, _, _)) = false 103 | | isSynVal (BINOPexp (CONS, e, e')) = isSynVal e andalso isSynVal e' 104 | | isSynVal (UOPexp ((ISNULL | NOT), e)) = isSynVal e 105 | | isSynVal (UOPexp (UMINUS, _)) = false 106 | | isSynVal (APPexp _) = false 107 | | isSynVal (ASSIGNexp _) = false 108 | | isSynVal (SELexp (Purity.Pure, e, _)) = isSynVal e 109 | | isSynVal (SELexp (Purity.Impure, _, _)) = false 110 | | isSynVal (BOOLexp _) = true 111 | | isSynVal (NUMBERexp _) = true 112 | | isSynVal (STRINGexp _) = true 113 | | isSynVal (VARexp _) = true 114 | | isSynVal (SEQexp el) = List.all isSynVal el 115 | | isSynVal (LISTexp el) = List.all isSynVal el 116 | | isSynVal (RECORDexp (Purity.Pure, fl)) = List.all isSynField fl 117 | | isSynVal (RECORDexp (Purity.Impure, _)) = false 118 | | isSynVal (MATCHexp (_, NONE)) = true 119 | | isSynVal (MATCHexp (_, SOME e)) = isSynVal e 120 | | isSynVal (TUPLEexp el) = List.all isSynVal el 121 | | isSynVal (CASEexp (e, { nilcase, conscase = (_, _, cc) })) = 122 | isSynVal e andalso isSynVal nilcase andalso isSynVal cc 123 | | isSynVal (CONexp (_, e)) = isSynVal e 124 | | isSynVal (SWIDENexp (e, _)) = isSynVal e 125 | | isSynVal (FNexp _) = true 126 | | isSynVal (PSCASEexp _) = false 127 | | isSynVal (TRYexp _) = false 128 | | isSynVal (RAISEexp _) = false 129 | | isSynVal (MARKexp (e, _)) = isSynVal e 130 | 131 | and isSynDef (VALdef (_, e)) = isSynVal e 132 | | isSynDef (FUNdef _) = true 133 | 134 | and isSynField (_, e) = isSynVal e 135 | end 136 | -------------------------------------------------------------------------------- /baseenv.sml: -------------------------------------------------------------------------------- 1 | (* baseenv.sml 2 | * 3 | * The "basis environment" with bindings for built-in values 4 | * for MLPolyR. The actual implementation of these values 5 | * resides in the runtime system (which is written in C). 6 | * 7 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 8 | *) 9 | structure BaseEnv : sig 10 | 11 | val elabBase : Types.typschema Env.env 12 | val transBase : Lambda.exp Env.env 13 | end = struct 14 | 15 | structure T = Types 16 | structure TU = TypesUtil 17 | 18 | val r = (0, 0) 19 | 20 | infix --> fun t1 --> t2 = let val rt = TU.freshrty0 (0, r) 21 | in T.FUNty (t1, t2, rt, r) 22 | end 23 | val int = T.INTty r 24 | val string = T.STRINGty r 25 | val unit = T.UNITty r 26 | fun tuple tl = T.TUPLEty (map (fn t => (t, r)) tl, r) 27 | fun list t = T.LISTty (t, r) 28 | 29 | val srecsym = Symbol.atom "String" 30 | val sreclabstring = "builtin_mlpr_String" 31 | val srecty = 32 | TU.mkRecordTyp 33 | ([("toInt", string --> int, r), 34 | ("fromInt", int --> string, r), 35 | ("inputLine", unit --> string, r), 36 | ("size", string --> int, r), 37 | ("output", string --> unit, r), 38 | ("sub", tuple [string, int] --> int, r), 39 | ("concat", list string --> string, r), 40 | ("substring", tuple [string, int, int] --> string, r), 41 | ("compare", tuple [string, string] --> int, r), 42 | ("cmdline_args", list string, r), 43 | ("cmdline_pgm", string, r)], 44 | r) 45 | 46 | val srectys : Types.typschema = #1 (TU.generalize 0 srecty) 47 | 48 | val srecexp = ExternalAccess.access sreclabstring 49 | 50 | val elabBase = Env.bind (srecsym, srectys, Env.empty) 51 | val transBase = Env.bind (srecsym, srecexp, Env.empty) 52 | end 53 | -------------------------------------------------------------------------------- /bbtree.sml: -------------------------------------------------------------------------------- 1 | (* bbtree.sml 2 | * 3 | * Basic Block Trees. 4 | * (This code is based on Andrew Appel's book "Modern Compiler 5 | * Implementation in ML", but it has been modified to capture 6 | * the invariants of basic blocks in ML types.) 7 | * 8 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 9 | *) 10 | structure BBTree = struct 11 | 12 | type temp = LVar.lvar 13 | type label = Label.label 14 | 15 | datatype exp = 16 | FETCH of lexp 17 | | BINOP of TreeOps.binop * exp * exp 18 | | NAME of label 19 | | CONST of LiteralData.integer 20 | 21 | and lexp = 22 | MEM of exp 23 | | TEMP of temp 24 | | ALLOCPTR 25 | | STACKPTR 26 | 27 | datatype preblock = 28 | JUMP of label (* unconditional jump *) 29 | | TCALL of exp * exp list (* tail call *) 30 | | RETURN of exp list (* return from function call *) 31 | | CJUMP of TreeOps.relop * exp * exp * label * label (* conditional j. *) 32 | | CALL of lexp list * exp * exp list * preblock (* call w/ multi-result *) 33 | | MOVE of lexp * exp * preblock (* assignment *) 34 | | DOEXP of exp * preblock (* evaluate expression for effect *) 35 | | DOCALL of exp * exp list * preblock (* evaluate call for effect *) 36 | | GCTEST of exp * preblock (* confirm availability of a number of bytes *) 37 | | ALLOCWRITE of exp * preblock 38 | (* allocate one word, bump alloc ptr. 39 | * ALLOCWRITE (e, b) is roughly equivalent to 40 | * MOVE (ALLOCPTR, BINOP (PLUS, FETCH ALLOCPTR, CONST 4), 41 | * MOVE (MEM (FETCH ALLOCPTR), exp, 42 | * preblock)) 43 | * It is guaranteed to be recognized by the code 44 | * generator and turned into a single instruction. 45 | *) 46 | | ALLOCCOPY of exp * exp * preblock 47 | (* ALLOCCOPY (frombase, len, b): 48 | * allocate len bytes, bump alloc ptr., copy contents 49 | * from region starting at frombase *) 50 | 51 | type block = label * preblock 52 | type entryblock = temp list * block * bool 53 | (* true: exception handler entry point *) 54 | 55 | type cluster = { entryblocks: entryblock list, 56 | labelblocks: block list } 57 | end 58 | -------------------------------------------------------------------------------- /closed.sml: -------------------------------------------------------------------------------- 1 | (* closed.sml 2 | * 3 | * This module describes the "Closed ANF" intermediate language 4 | * which is the output of MLPolyR's closure conversion. 5 | * 6 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 7 | *) 8 | structure Closed = struct 9 | 10 | type lvar = LVar.lvar 11 | type label = Label.label 12 | datatype value = datatype Lambda.value 13 | 14 | datatype exp = 15 | VALUES of value list 16 | | BIND of lvar * value * exp 17 | | CALL of Purity.purity * lvar list * jtarget * exp 18 | | ARITH of Oper.arithop * value * value * lvar * exp 19 | | RECORD of Purity.purity * value * slice list * lvar * exp 20 | | SELECT of value * value * Purity.purity * lvar * exp 21 | | UPDATE of value * value * value * exp 22 | | CMP of Oper.cmpop * value * value * btarget * btarget 23 | | JUMP of jtarget 24 | | GETSP of lvar * exp 25 | | SETSP of value * exp 26 | | MAYJUMP of label * exp 27 | and slice = 28 | SGT of value 29 | | SEQ of { base: value, start: value, stop: value } 30 | withtype jtarget = value * value list 31 | and btarget = label * value list 32 | 33 | type block = label * lvar list * exp 34 | type entryblock = label * lvar list * exp * bool 35 | (* true: exception handler entry point *) 36 | 37 | type program = { calltargets: entryblock list, 38 | jumptargets: block list, 39 | entrypoint: entryblock } 40 | 41 | type cluster = { entryblocks: entryblock list, labelblocks: block list } 42 | end 43 | -------------------------------------------------------------------------------- /color.sml: -------------------------------------------------------------------------------- 1 | (* color.sml 2 | * 3 | * The graph-coloring part of a simple register allocator. 4 | * 5 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | structure Color : sig 8 | 9 | val color : { interference: Liveness.igraph, 10 | initial: Frame.allocation, 11 | spillCost: Liveness.IGraph.node -> int, 12 | registers : Frame.register list } 13 | -> Frame.allocation * LVar.lvar list 14 | 15 | end = struct 16 | 17 | structure Frame = Frame 18 | structure L = Liveness 19 | structure IG = L.IGraph 20 | structure TT = LVar.Map 21 | structure GT = IG.Map 22 | structure TS = LVar.Set 23 | 24 | fun color { interference, initial, spillCost, registers } = 25 | let val k = length registers 26 | val L.IGRAPH { graph, tnode, gtemp, moves } = interference 27 | val nodes = IG.nodes graph 28 | fun adjacent n = let 29 | fun uniq ([], u) = u 30 | | uniq (h :: t, u) = 31 | uniq (t, if List.exists (fn n => IG.eq (h, n)) u then u 32 | else h :: u) 33 | in 34 | uniq (IG.adj n, []) 35 | end 36 | val degreeOf = length o adjacent 37 | 38 | fun spillCost' n = spillCost n - degreeOf n 39 | 40 | (* eligible nodes -- not precolored *) 41 | val nodes' = 42 | List.filter (fn n => not (TT.inDomain (initial, gtemp n))) 43 | nodes 44 | 45 | fun categ (n, (low, high, m)) = let 46 | val d = degreeOf n 47 | val m' = GT.insert (m, n, d) 48 | in 49 | if d < k then (n :: low, high, m') else (low, n :: high, m') 50 | end 51 | 52 | val (low, high, dm) = foldl categ ([], [], GT.empty) nodes' 53 | 54 | 55 | fun select (n, low, high, dm) = let 56 | val adj = adjacent n 57 | val dm = #1 (GT.remove (dm, n)) 58 | fun otherThan n1 n2 = not (IG.eq (n1, n2)) 59 | fun lowerDegree (a, (low, high, dm)) = 60 | case GT.find (dm, a) of 61 | NONE => (low, high, dm) 62 | | SOME d => let 63 | val d' = d - 1 64 | val dm = GT.insert (dm, a, d') 65 | in 66 | if d = k then 67 | (a :: low, List.filter (otherThan a) high, dm) 68 | else (low, high, dm) 69 | end 70 | val (low, high, dm) = foldl lowerDegree (low, high, dm) adj 71 | in 72 | (low, high, dm, adj) 73 | end 74 | 75 | fun pickColor (n, adj, (allocation, spills)) = let 76 | fun remove (a, avail) = 77 | case TT.find (allocation, gtemp a) of 78 | NONE => avail 79 | | SOME r => List.filter (fn r' => r <> r') avail 80 | 81 | fun biasedPick [] = (allocation, gtemp n :: spills) 82 | | biasedPick avail = let 83 | fun frequency c = let 84 | fun cColored x = 85 | case TT.find (allocation, gtemp x) of 86 | NONE => false 87 | | SOME c' => c = c' 88 | fun count ([], cnt) = cnt 89 | | count ((n1, n2) :: ml, cnt) = 90 | if IG.eq (n1, n) andalso cColored n2 91 | orelse IG.eq (n2, n) andalso cColored n1 then 92 | count (ml, cnt + 1) 93 | else count (ml, cnt) 94 | in 95 | count (moves, 0) 96 | end 97 | fun loop ([], best, _) = 98 | (TT.insert (allocation, gtemp n, best), spills) 99 | | loop (c :: cs, b, m) = let 100 | val cfreq = frequency c 101 | in 102 | if cfreq > m then loop (cs, c, cfreq) 103 | else loop (cs, b, m) 104 | end 105 | in 106 | loop (avail, Frame.boguscolor, ~1) 107 | end 108 | 109 | (* (* for unbiased coloring... *) 110 | fun biasedPick [] = ErrorMsg.impossible "run out of registers" 111 | | biasedPick (first :: _) = 112 | TT.enter (allocation, gtemp n, first) 113 | *) 114 | in 115 | biasedPick (foldl remove registers adj) 116 | end 117 | 118 | fun try ([], [], _) = (initial, []) 119 | | try ([], h1 :: hn, dm) = let 120 | fun cheapest (h1, _, [], hn') = (h1, hn') 121 | | cheapest (h1, c1, h2 :: hn, hn') = let 122 | val c2 = spillCost' h2 123 | in 124 | if c2 < c1 then 125 | cheapest (h2, c2, hn, h1 :: hn') 126 | else 127 | cheapest (h1, c1, hn, h2 :: hn') 128 | end 129 | val (h1', hn') = cheapest (h1, spillCost' h1, hn, []) 130 | in 131 | finish (h1', select (h1', [], hn', dm)) 132 | end 133 | | try (l1 :: ln, high, dm) = 134 | finish (l1, select (l1, ln, high, dm)) 135 | 136 | and finish (n, (low, high, dm, adj)) = 137 | pickColor (n, adj, try (low, high, dm)) 138 | in 139 | try (low, high, dm) 140 | end 141 | end 142 | -------------------------------------------------------------------------------- /doc/.cvsignore: -------------------------------------------------------------------------------- 1 | *.aux 2 | *.log 3 | *.pdf 4 | *.dvi 5 | -------------------------------------------------------------------------------- /doc/langspec.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/owo-lang/MLPolyR/245631216d54ab787fc51fed808e335aeebf85d5/doc/langspec.pdf -------------------------------------------------------------------------------- /env.sml: -------------------------------------------------------------------------------- 1 | (* env.sml 2 | * 3 | * The functional environment data structure used by the elaborator. 4 | * 5 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | structure Env :> sig 8 | 9 | type 'a env 10 | 11 | val empty : 'a env 12 | val bind : Symbol.atom * 'a * 'a env -> 'a env 13 | val find : 'a env * Symbol.atom -> 'a option 14 | val map : ('a -> 'b) -> 'a env -> 'b env 15 | 16 | end = struct 17 | 18 | structure M = Symbol.Map 19 | 20 | type 'a env = 'a M.map 21 | 22 | val empty = M.empty 23 | fun bind (v, x, e) = M.insert (e, v, x) 24 | fun find (e, v) = M.find (e, v) 25 | fun map f e = M.map f e 26 | 27 | end 28 | -------------------------------------------------------------------------------- /extacc.sml: -------------------------------------------------------------------------------- 1 | (* extacc.sml 2 | * 3 | * Generating code that facilitates access to run-time system 4 | * functionality. 5 | * 6 | * Copyright (C) 2006 by Matthias Blume (blume@tti-c.org) 7 | *) 8 | structure ExternalAccess : sig 9 | 10 | val access : string -> Lambda.exp 11 | 12 | end = struct 13 | 14 | fun access s = 15 | let val lab = Label.external s 16 | in Lambda.ARITH (Oper.PLUS, Lambda.VALUE (Lambda.LABEL lab), 17 | Lambda.VALUE (Lambda.INT 1)) 18 | end 19 | end 20 | -------------------------------------------------------------------------------- /flatten.sml: -------------------------------------------------------------------------------- 1 | (* flatten.sml 2 | * 3 | * Perform header-transformation (eta-splitting) 4 | * to flatten parameter list. 5 | * 6 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 7 | *) 8 | structure Flatten : sig 9 | 10 | val transform: ANF.function -> ANF.function 11 | 12 | end = struct 13 | 14 | val K = MachSpec.numArgs 15 | 16 | structure A = ANF 17 | structure M = LVar.Map 18 | structure S = LVar.Set 19 | 20 | fun bug m = ErrorMsg.impossible ("Flatten: " ^ m) 21 | 22 | fun getinfo f = 23 | let val m = ref M.empty 24 | 25 | fun function { f = (f, vl, e), inl, hdlr } = 26 | let fun candidate v = 27 | m := M.insert (!m, v, (f, ref (SOME []))) 28 | 29 | fun sel (v, i, w) = 30 | case M.find (!m, v) of 31 | NONE => () 32 | | SOME (_, ref NONE) => () 33 | | SOME (f', r as ref (SOME im)) => 34 | if f = f' then 35 | (r := SOME ((i, w) :: im); 36 | candidate w) 37 | else r := NONE 38 | 39 | fun var v = 40 | case M.find (!m, v) of 41 | NONE => () 42 | | SOME (_, r) => r := NONE 43 | 44 | fun value (A.VAR v) = var v 45 | | value _ = () 46 | 47 | fun slice (A.SGT x) = value x 48 | | slice (A.SEQ { base, start, stop }) = 49 | (value base; value start; value stop) 50 | 51 | fun exp _ (A.VALUES xl) = 52 | app value xl 53 | | exp r (A.BIND (_, x, e)) = 54 | (* we expect this case not to happen because 55 | * earlier rounds get rid of it *) 56 | (value x; exp r e) 57 | | exp r (A.CALL (_, _, (x, xl), e)) = 58 | (value x; app value xl; exp r e) 59 | | exp r (A.FIX (fl, e)) = 60 | (app function fl; exp r e) 61 | | exp r (A.ARITH (_, x, y, _, e)) = 62 | (value x; value y; exp r e) 63 | | exp r (A.RECORD (_, x, sl, _, e)) = 64 | (value x; app slice sl; exp r e) 65 | | exp false (A.SELECT (A.VAR v, A.INT i, 66 | Purity.Pure, w, e)) = 67 | (sel (v, i, w); exp false e) 68 | | exp r (A.SELECT (x, y, _, _, e)) = 69 | (value x; value y; exp r e) 70 | | exp r (A.UPDATE (x, y, z, e)) = 71 | (value x; value y; value z; exp r e) 72 | | exp _ (A.CMP (_, x, y, et, ef)) = 73 | (value x; value y; exp true et; exp true ef) 74 | | exp _ (A.JUMP (_, (x, xl))) = 75 | (value x; app value xl) 76 | | exp r (A.GETSP (v, e)) = 77 | exp r e 78 | | exp r (A.SETSP (x, e)) = 79 | (value x; exp r e) 80 | | exp r (A.MAYJUMP (v, e)) = 81 | (var v; exp r e) 82 | in app candidate vl; 83 | exp false e 84 | end 85 | in function f; 86 | !m 87 | end 88 | 89 | fun transform (f as { f = (fname, vl, e), inl, hdlr }) = 90 | let val m = getinfo f 91 | fun grow (_, newformals, [], rsel, elims) = 92 | (rev newformals, rsel, elims) 93 | | grow (0, newformals1, newformals2, rsel, elims) = 94 | (List.revAppend (newformals1, newformals2), rsel, elims) 95 | | grow (k, nf1, h :: t, rsel, elims) = 96 | (case M.find (m, h) of 97 | NONE => 98 | grow (k, h :: nf1, t, rsel, elims) 99 | | SOME (_, ref NONE) => 100 | grow (k, h :: nf1, t, rsel, elims) 101 | | SOME (_, ref (SOME im)) => 102 | let val n = length im - 1 103 | in if n > k then 104 | grow (k, h :: nf1, t, rsel, elims) 105 | else let val targets = map #2 im 106 | in grow (k - n, nf1, 107 | targets @ t, 108 | map (fn (i, v) => (h, i, v)) im @ 109 | rsel, 110 | targets @ elims) 111 | end 112 | end) 113 | fun onefun ({ f = (f, vl, e), inl, hdlr }, fl) = 114 | case grow (K - length vl, [], vl, [], []) of 115 | (_, _, []) => { f = (f, vl, rewrite (S.empty, e)), 116 | inl = inl, hdlr = hdlr } :: fl 117 | | (vl', rsel, elims) => 118 | let val f' = LVar.clone f 119 | fun get m v = getOpt (M.find (m, v), v) 120 | fun rename (v, m) = 121 | let val v' = LVar.clone v 122 | in (v', M.insert (m, v, v')) 123 | end 124 | fun rename' ([], m) = ([], m) 125 | | rename' (h :: t, m) = 126 | let val (h', m') = rename (h, m) 127 | val (t', m'') = rename' (t, m') 128 | in (h' :: t', m'') 129 | end 130 | val (vl'', m) = rename' (vl, M.empty) 131 | fun build ([], m) = 132 | (A.JUMP (Purity.Impure, 133 | (A.VAR f', 134 | map (A.VAR o get m) vl'))) 135 | | build ((v, i, w) :: sel, m) = 136 | let val v' = get m v 137 | val (w', m') = rename (w, m) 138 | val b = build (sel, m') 139 | in A.SELECT (A.VAR v', A.INT i, 140 | Purity.Pure, w', b) 141 | end 142 | val b = build (rev rsel, m) 143 | val s = S.addList (S.empty, elims) 144 | val b' = rewrite (s, e) 145 | in { f = (f, vl'', b), inl = true, hdlr = hdlr } :: 146 | { f = (f', vl', b'), inl = inl, hdlr = hdlr } :: 147 | fl 148 | end 149 | and rewrite (s, e) = 150 | let fun exp (e as A.VALUES _) = e 151 | | exp (A.BIND (v, x, e)) = 152 | A.BIND (v, x, exp e) 153 | | exp (A.CALL (p, vl, (x, xl), e)) = 154 | A.CALL (p, vl, (x, xl), exp e) 155 | | exp (A.FIX (fl, e)) = 156 | A.FIX (foldr onefun [] fl, exp e) 157 | | exp (A.ARITH (aop, x, y, v, e)) = 158 | A.ARITH (aop, x, y, v, exp e) 159 | | exp (A.RECORD (p, x, sl, v, e)) = 160 | A.RECORD (p, x, sl, v, exp e) 161 | | exp (A.SELECT (x, y, p, v, e)) = 162 | if S.member (s, v) then exp e 163 | else A.SELECT (x, y, p, v, exp e) 164 | | exp (A.UPDATE (x, y, z, e)) = 165 | A.UPDATE (x, y, z, exp e) 166 | | exp (A.CMP (cop, x, y, et, ef)) = 167 | A.CMP (cop, x, y, exp et, exp ef) 168 | | exp (A.GETSP (v, e)) = 169 | A.GETSP (v, exp e) 170 | | exp (A.SETSP (x, e)) = 171 | A.SETSP (x, exp e) 172 | | exp (A.MAYJUMP (v, e)) = 173 | A.MAYJUMP (v, exp e) 174 | | exp (e as A.JUMP _) = e 175 | in exp e 176 | end 177 | in { f = (fname, vl, rewrite (S.empty, e)), inl = inl, hdlr = hdlr } 178 | end 179 | end 180 | -------------------------------------------------------------------------------- /flowgraph.sml: -------------------------------------------------------------------------------- 1 | (* flowgraph.sml 2 | * 3 | * Representing flow graphs. 4 | * This code is taken from Andrew Appel's book "Modern Compiler 5 | * Implementation in ML". 6 | *) 7 | structure Flow = struct 8 | structure Graph = Graph 9 | datatype flowgraph = 10 | FGRAPH of 11 | { 12 | (* control: directed graph representing control flow 13 | * from instruction to instruction. (Each graph 14 | * node represents one instruction. *) 15 | control: Graph.graph, 16 | (* def: mapping from graph nodes to sets of variables 17 | * defined at these nodes *) 18 | def: LVar.Set.set Graph.Map.map, 19 | (* use: mapping from graph nodes to sets of variables 20 | * used at these nodes *) 21 | use: LVar.Set.set Graph.Map.map, 22 | (* ismove: mapping from graph nodes to a boolean telling 23 | * whether the corresponding instruction was a 24 | * MOVE *) 25 | ismove: bool Graph.Map.map 26 | } 27 | 28 | (* Note: any "use" within the block is assumed to be BEFORE a "def" 29 | of the same variable. If there is a def(x) followed by use(x) 30 | in the same block, do not mention the use in this data structure, 31 | mention only the def. 32 | 33 | More generally: 34 | If there are any nonzero number of defs, mention def(x). 35 | If there are any nonzero number of uses BEFORE THE FIRST DEF, 36 | mention use(x). 37 | 38 | For any node in the graph, 39 | Graph.Table.look(def,node) = SOME(def-list) 40 | Graph.Table.look(use,node) = SOME(use-list) 41 | *) 42 | 43 | end 44 | -------------------------------------------------------------------------------- /frame.sml: -------------------------------------------------------------------------------- 1 | (* frame.sml 2 | * 3 | * Information about PowerPC registers and stack frames. 4 | * There is one frame per cluster. The layout of these 5 | * frames and register conventions are compatible with 6 | * the Mach-O conventions used by Apple's Mac OS X operating 7 | * system. 8 | * 9 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 10 | *) 11 | structure Frame = struct 12 | 13 | datatype frame = 14 | FRAME of { argAreaTop : int ref, (* keep track of largest call *) 15 | nextSpill : int ref, (* keep track of all spills *) 16 | szName : string, 17 | spillName : string 18 | } 19 | 20 | type register = int 21 | type allocation = register LVar.Map.map 22 | 23 | fun showTemp allocation t = 24 | case LVar.Map.find (allocation, t) of 25 | SOME n => "r" ^ Int.toString n 26 | | NONE => LVar.toString t 27 | 28 | local fun s i = LVar.special (i, "r" ^ Int.toString i) 29 | fun s8 i = (s i, s (i + 1), s (i + 2), s (i + 3), 30 | s (i + 4), s (i + 5), s (i + 6), s (i + 7)) 31 | in 32 | (* temporaries representing all physical registers *) 33 | val (r0, r1, r2, r3, r4, r5, r6, r7) = s8 0 34 | val (r8, r9, r10, r11, r12, r13, r14, r15) = s8 8 35 | val (r16, r17, r18, r19, r20, r21, r22, r23) = s8 16 36 | val (r24, r25, r26, r27, r28, r29, r30, r31) = s8 24 37 | end 38 | 39 | val boguscolor = ~1 40 | val sp = r1 (* stack pointer *) 41 | val indirfunptr = r12 (* function ptr for indirect calls *) 42 | val untagscratch = r12 (* Scratch register for holding 43 | * untagged (GC-unsafe) ints 44 | * temporarily. These values must 45 | * not be spilled or otherwise 46 | * be stored on the stack or in the 47 | * heap. *) 48 | val arg1 = r3 (* first argument register *) 49 | (* temporaries representing caller-save, callee-save, and argument-regs *) 50 | val callersaves = [r2, r3, r4, r5, r6, r7, r8, r9, r10, r11, r12] 51 | val calleesaves = [r15, r16, r17, r18, r19, r20, r21, r22, r23, r24, 52 | r25, r26, r27, r28, r29, r30, r31] 53 | val args = [r3, r4, r5, r6, r7, r8, r9, r10] 54 | val nargs = length args 55 | val results = args (* function result registers *) 56 | val nresults = length results 57 | 58 | val allocptr = r13 59 | val limitptr = r14 60 | 61 | val specialVars = [sp, allocptr, limitptr] 62 | 63 | (* the initial coloring (or "precoloring") which maps temporaries 64 | * representing physical registers to their respective hard-wired 65 | * color *) 66 | val precoloring = 67 | ListPair.foldl 68 | (fn (t, r, m) => LVar.Map.insert (m, t, r)) 69 | LVar.Map.empty 70 | ([r0, r1, r2, r3, r4, r5, r6, r7, 71 | r8, r9, r10, r11, r12, r13, r14, r15, 72 | r16, r17, r18, r19, r20, r21, r22, r23, 73 | r24, r25, r26, r27, r28, r29, r30, r31], 74 | [0, 1, 2, 3, 4, 5, 6, 7, 75 | 8, 9, 10, 11, 12, 13, 14, 15, 76 | 16, 17, 18, 19, 20, 21, 22, 23, 77 | 24, 25, 26, 27, 28, 29, 30, 31]) 78 | 79 | local 80 | fun t2r t = valOf (LVar.Map.find (precoloring, t)) 81 | in 82 | (* registers corresponding to "callersaves" and "calleesaves" *) 83 | val callersaveRegs = map t2r callersaves 84 | val calleesaveRegs = rev (map t2r calleesaves) 85 | val specialRegs = map t2r specialVars 86 | (* all registers available for coloring *) 87 | val registers = callersaveRegs @ calleesaveRegs @ specialRegs 88 | end 89 | 90 | (* offset of argument area from stack pointer *) 91 | val argAreaBottom = 24 92 | 93 | (* keep track of largest call, adjust argAreaTop accordingly *) 94 | fun recordArgAreaTop (FRAME { argAreaTop, ... }, t) = 95 | if t > !argAreaTop then argAreaTop := t else () 96 | 97 | fun frameSzName (FRAME f) = #szName f 98 | fun frameSpillName (FRAME f) = #spillName f 99 | 100 | fun hasSpills (FRAME { nextSpill, ... }) = !nextSpill <> 0 101 | 102 | fun new l = 103 | let val szl = Label.external (Label.name l ^ "_FRAMESIZE") 104 | val spl = Label.external (Label.name l ^ "_SPILL") 105 | in FRAME { argAreaTop = ref argAreaBottom, 106 | nextSpill = ref 0, 107 | szName = Label.escname szl, 108 | spillName = Label.escname spl } 109 | end 110 | 111 | val gclab = Label.external "mlpr_gc" 112 | val gcstublab = Label.external "mlpr_gc_stub" 113 | val gcstublabname = Label.escname gcstublab 114 | 115 | (* allocate slot in stack frame for a spilled temporary *) 116 | fun allocSpill (FRAME { nextSpill, ... }) = 117 | let val off = !nextSpill + 4 118 | in nextSpill := off; 119 | off 120 | end 121 | 122 | fun spillOff (FRAME { spillName, ... }) off = 123 | concat [spillName, "-", Int.toString off] 124 | 125 | fun regSaveRestoreInfo (FRAME f, allocation) = 126 | let fun one (t, i, min) = 127 | if not (LVar.Map.inDomain (precoloring, t)) 128 | andalso i >= 15 andalso i < min 129 | then i 130 | else min 131 | val low = LVar.Map.foldli one 32 allocation 132 | val sz_lower = !(#argAreaTop f) 133 | val n_regsave = 32 - low 134 | val sz_regsave = n_regsave * 4 135 | val sz_spills = !(#nextSpill f) 136 | val sz_upper = sz_regsave + sz_spills 137 | val sz_unpadded = sz_lower + sz_upper 138 | val sz = 139 | case sz_unpadded mod 16 of 140 | 0 => sz_unpadded 141 | | odd => sz_unpadded + 16 - odd 142 | (* Spill locations on the stack get initialized so that 143 | * they do not contain random stuff which would confuse 144 | * the GC: *) 145 | val spillinit = 146 | if hasSpills (FRAME f) then 147 | let fun loop (i, a) = 148 | if i > 0 then 149 | loop (i-4, concat ["\tstw r0,", 150 | #spillName f, "-", 151 | Int.toString i, 152 | "(r1)"] 153 | :: a) 154 | else a 155 | in "\tli r0,0" :: loop (sz_spills, []) 156 | end 157 | else [] 158 | val (stmw, lmw) = 159 | if sz_regsave > 0 then 160 | let val tail = 161 | concat [" r", Int.toString low, ",", 162 | #szName f, "-", 163 | Int.toString sz_regsave, "(r1)"] 164 | in 165 | (["\tstmw" ^ tail], ["\tlmw" ^ tail]) 166 | end 167 | else ([], []) 168 | in { save = spillinit @ stmw, restore = lmw, 169 | size = sz, sz_regsave = sz_regsave, sz_upper = sz_upper } 170 | end 171 | end 172 | -------------------------------------------------------------------------------- /graph.sig: -------------------------------------------------------------------------------- 1 | (* graph.sig 2 | * 3 | * Signature describing a generic graph implemenation. 4 | *) 5 | signature GRAPH = sig 6 | 7 | type graph 8 | type node 9 | 10 | val nodes: graph -> node list 11 | val succ: node -> node list 12 | val pred: node -> node list 13 | val adj: node -> node list (* succ+pred *) 14 | val eq: node*node -> bool 15 | 16 | val newGraph: unit -> graph 17 | val newNode : graph -> node 18 | exception GraphEdge 19 | val mk_edge: {from: node, to: node} -> unit 20 | val rm_edge: {from: node, to: node} -> unit 21 | 22 | structure Map : ORD_MAP where type Key.ord_key = node 23 | 24 | val nodename: node->string (* for debugging only *) 25 | end 26 | -------------------------------------------------------------------------------- /graph.sml: -------------------------------------------------------------------------------- 1 | (* graph.sml 2 | * 3 | * Generic graphs. 4 | *) 5 | structure Graph :> GRAPH = struct 6 | 7 | type node' = int 8 | 9 | datatype noderep = NODE of {succ: node' list, pred: node' list} 10 | 11 | val emptyNode = NODE{succ=[],pred=[]} 12 | 13 | val bogusNode = NODE{succ=[~1],pred=[]} 14 | 15 | fun isBogus(NODE{succ= ~1::_,...}) = true 16 | | isBogus _ = false 17 | 18 | structure A = DynamicArrayFn(struct open Array 19 | type elem = noderep 20 | type vector = noderep vector 21 | type array = noderep array 22 | end) 23 | 24 | type graph = A.array 25 | 26 | type node = graph * node' 27 | fun eq((_,a):node,(_,b)) = a=b 28 | 29 | fun augment (g: graph) (n: node') : node = (g,n) 30 | 31 | fun newGraph() = A.array(0,bogusNode) 32 | 33 | fun nodes g = let val b = A.bound g 34 | fun f i = if isBogus( A.sub(g,i)) then nil 35 | else (g,i)::f(i+1) 36 | in f 0 37 | end 38 | 39 | fun succ(g,i) = let val NODE{succ=s,...} = A.sub(g,i) 40 | in map (augment g) s 41 | end 42 | fun pred(g,i) = let val NODE{pred=p,...} = A.sub(g,i) 43 | in map (augment g) p 44 | end 45 | fun adj gi = pred gi @ succ gi 46 | 47 | fun newNode g = (* binary search for unused node *) 48 | let fun look(lo,hi) = 49 | (* i < lo indicates i in use 50 | i >= hi indicates i not in use *) 51 | if lo=hi then (A.update(g,lo,emptyNode); (g,lo)) 52 | else let val m = (lo+hi) div 2 53 | in if isBogus(A.sub(g,m)) then look(lo,m) else look(m+1,hi) 54 | end 55 | in look(0, 1 + A.bound g) 56 | end 57 | 58 | exception GraphEdge 59 | fun check(g,g') = (* if g=g' then () else raise GraphEdge *) () 60 | 61 | fun delete(i:node',j::rest) = if i=j then rest else j::delete(i,rest) 62 | | delete(_,nil) = raise GraphEdge 63 | 64 | fun diddle_edge change {from=(g:graph, i),to=(g':graph, j)} = 65 | let val _ = check(g,g') 66 | val NODE{succ=si,pred=pi} = A.sub(g,i) 67 | val _ = A.update(g,i,NODE{succ=change(j,si),pred=pi}) 68 | val NODE{succ=sj,pred=pj} = A.sub(g,j) 69 | val _ = A.update(g,j,NODE{succ=sj,pred=change(i,pj)}) 70 | in () 71 | end 72 | 73 | val mk_edge = diddle_edge (op ::) 74 | val rm_edge = diddle_edge delete 75 | 76 | structure Map = RedBlackMapFn (type ord_key = node 77 | fun compare ((_, i), (_, i')) = 78 | Int.compare (i, i')) 79 | 80 | 81 | fun nodename(g,i:int) = "n" ^ Int.toString(i) 82 | 83 | end 84 | -------------------------------------------------------------------------------- /interp.sml: -------------------------------------------------------------------------------- 1 | (* 2 | * Lambda representation based interpreter. 3 | * Copyright (c) 2019 by LdBeth 4 | *) 5 | 6 | structure Interpreter : sig 7 | 8 | val runtime : Label.label -> LambdaInterpreter.value 9 | val makeProgram : Lambda.function -> Lambda.exp 10 | val printResult : LambdaInterpreter.value -> unit 11 | 12 | end = struct 13 | 14 | structure L = Lambda 15 | 16 | (* stub runtime *) 17 | fun runtime label = let val _ = print "Called label: " 18 | val _ = print (Label.name label) 19 | val _ = print "\n" 20 | in 21 | raise Fail "I/O is still a stub" 22 | end 23 | 24 | (* helpers *) 25 | fun intv i = L.VALUE (L.INT i) 26 | fun varv i = L.VALUE (L.VAR i) 27 | 28 | (* stub eh function *) 29 | val ehfun : L.function = (LVar.new "eh", [], intv 255 ,false) 30 | 31 | fun makeProgram def = 32 | let val (fname, _, _, _) = def 33 | val (eh, _, _, _) = ehfun 34 | in 35 | L.FIX ([def,ehfun], L.APP (Purity.Impure, varv fname, [varv eh])) 36 | end 37 | 38 | fun printResult (LambdaInterpreter.INTv i) = 39 | (print "Result is: "; 40 | print (LiteralData.toString (i div 2)); (* MLPolyR use even num for int *) 41 | print "\n") 42 | | printResult _ = raise Fail "Panic!" 43 | 44 | end 45 | -------------------------------------------------------------------------------- /label.sml: -------------------------------------------------------------------------------- 1 | (* label.sml 2 | * 3 | * Representing assembly labels in the MLPolyR compiler. 4 | * 5 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | structure Label :> sig 8 | 9 | structure Atom : ATOM 10 | 11 | type label = Atom.atom 12 | 13 | structure Set : ORD_SET where type Key.ord_key = label 14 | structure Map : ORD_MAP where type Key.ord_key = label 15 | 16 | val new : LVar.lvar option -> label 17 | val external : string -> label 18 | val stringlabel : unit -> label 19 | 20 | val reset : unit -> unit 21 | 22 | val isExternal : label -> bool 23 | 24 | val name : label -> string 25 | val escname : label -> string 26 | 27 | val compare : label * label -> order 28 | 29 | end = struct 30 | 31 | structure Atom = Atom 32 | 33 | structure Set = AtomRedBlackSet 34 | structure Map = AtomRedBlackMap 35 | 36 | type label = Atom.atom 37 | 38 | val next = ref 0 39 | val externals = ref Set.empty 40 | fun reset () = next := 0 41 | 42 | fun freshid () = let val n = !next in next := n+1; n end 43 | 44 | fun new NONE = Atom.atom ("l_" ^ Int.toString (freshid ())) 45 | | new (SOME v) = Atom.atom ("l_" ^ Int.toString (freshid ()) 46 | ^ "_" ^ LVar.baseName v) 47 | 48 | fun stringlabel () = 49 | Atom.atom ("l_mlpr_string_" ^ Int.toString (freshid ())) 50 | 51 | fun external s = 52 | let val l = Atom.atom ("_" ^ s) 53 | in externals := Set.add (!externals, l); 54 | l 55 | end 56 | 57 | fun isExternal l = Set.member (!externals, l) 58 | 59 | val name = Atom.toString 60 | fun escname l = 61 | let val n = name l 62 | in if Char.contains n #"'" then concat ["\"", n, "\""] else n 63 | end 64 | 65 | val compare = Atom.compare 66 | end 67 | -------------------------------------------------------------------------------- /lambda-interpreter.sml: -------------------------------------------------------------------------------- 1 | (* lambda-interpreter.sml 2 | * 3 | * A meta-circular interpreter of the Lambda language 4 | * used by the MLPolyR compiler. 5 | * 6 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 7 | *) 8 | structure LambdaInterpreter : sig 9 | 10 | datatype value = 11 | INTv of LiteralData.integer 12 | | RECv of recfields 13 | | FUNv of value list -> value list 14 | withtype recfields = value ref list 15 | 16 | val eval : (Label.label -> value) -> Lambda.exp -> value 17 | 18 | end = struct 19 | 20 | structure L = Lambda 21 | 22 | datatype value = 23 | INTv of LiteralData.integer 24 | | RECv of recfields 25 | | FUNv of value list -> value list 26 | withtype recfields = value ref list 27 | 28 | fun vINT (INTv i) = i 29 | | vINT _ = raise Fail "integer required" 30 | fun vREC (RECv xrl) = xrl 31 | | vREC _ = raise Fail "record required" 32 | fun vFUN (FUNv f) xl = 33 | (case f xl of 34 | [y] => y 35 | | _ => ErrorMsg.impossible "LambdaInterpreter: multiple results") 36 | | vFUN _ _ = raise Fail "function required" 37 | 38 | fun tuple xl = RECv (map ref xl) 39 | 40 | fun bind (v: LVar.lvar, x, env) v' = if v = v' then x else env v' 41 | fun bindl (vl, xl, env) = ListPair.foldl bind env (vl, xl) 42 | 43 | fun recidx i = LiteralData.toInt (i div MachSpec.wordSize) 44 | 45 | fun eval labenv e = 46 | let fun value (L.VAR v, env) = env v 47 | | value (L.LABEL l, _) = labenv l 48 | | value (L.INT i, _) = INTv i 49 | fun exp (L.VALUE x, env) = 50 | value (x, env) 51 | | exp (L.LET (v, e, b), env) = 52 | exp (b, bind (v, exp (e, env), env)) 53 | | exp (L.FIX (fl, b), env) = 54 | let fun env' v0 = 55 | case List.find (fn (f, _, _, _) => f = v0) fl of 56 | SOME (f, vl, e, _) => 57 | FUNv (fn xl => 58 | [exp (e, bindl (vl, xl, env'))]) 59 | | NONE => env v0 60 | in exp (b, env') 61 | end 62 | | exp (L.ARITH (aop, e1, e2), env) = 63 | INTv (Oper.doarith (aop, vINT (exp (e1, env)), 64 | vINT (exp (e2, env)))) 65 | | exp (L.RECORD { purity, len, slices }, env) = 66 | let val _ = exp (len, env) (* for effect *) 67 | fun build [] = [] 68 | | build (L.SGT e :: sl) = 69 | exp (e, env) :: build sl 70 | | build (L.SEQ { base, start, stop } :: sl) = 71 | let val br = vREC (exp (base, env)) 72 | val s = vINT (exp (start, env)) 73 | val e = vINT (exp (stop, env)) 74 | fun grow i = 75 | if i >= e then build sl 76 | else !(List.nth (br, recidx i)) 77 | :: grow (i+MachSpec.wordSize) 78 | in grow s 79 | end 80 | in tuple (build slices) 81 | end 82 | | exp (L.SELECT (e1, e2, _), env) = 83 | let val (erl, i) = 84 | (vREC (exp (e1, env)), vINT (exp (e2, env))) 85 | in !(List.nth (erl, recidx i)) 86 | end 87 | | exp (L.UPDATE (e1, e2, e3), env) = 88 | let val (erl, i, v) = 89 | (vREC (exp (e1, env)), 90 | vINT (exp (e2, env)), 91 | exp (e3, env)) 92 | in List.nth (erl, recidx i) := v; 93 | INTv 0 94 | end 95 | | exp (L.CMP (cop, e1, e2, et, ee), env) = 96 | if Oper.docmp (cop, vINT (exp (e1, env)), 97 | vINT (exp (e2, env))) 98 | then exp (et, env) 99 | else exp (ee, env) 100 | | exp (L.APP (_, e, el), env) = 101 | vFUN (exp (e, env)) 102 | (map (fn e => (exp (e, env))) el) 103 | | exp (L.HANDLER (hv, hvl, hb, b), env) = 104 | let exception E of value list 105 | in exp (b, bind (hv, FUNv (fn xl => raise E xl), env)) 106 | handle E xl => exp (hb, bindl (hvl, xl, env)) 107 | end 108 | in exp (e, fn _ => raise Fail "unbound variable") 109 | end 110 | end 111 | -------------------------------------------------------------------------------- /lambda.sml: -------------------------------------------------------------------------------- 1 | (* lambda.sml 2 | * 3 | * The Lambda intermediate language of the MLPolyR compiler. 4 | * Lambda is the output of the Translate phase. 5 | * 6 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 7 | *) 8 | structure Lambda = struct 9 | 10 | type lvar = LVar.lvar 11 | type purity = Purity.purity 12 | 13 | datatype value = 14 | VAR of lvar 15 | | LABEL of Label.label 16 | | INT of LiteralData.integer 17 | 18 | datatype exp = 19 | VALUE of value 20 | | LET of lvar * exp * exp 21 | | FIX of function list * exp 22 | | ARITH of Oper.arithop * exp * exp 23 | | RECORD of { purity: purity, len: exp, slices: slice list } 24 | | SELECT of exp * exp * purity 25 | | UPDATE of exp * exp * exp 26 | | CMP of Oper.cmpop * exp * exp * exp * exp 27 | | APP of purity * exp * exp list 28 | | HANDLER of lvar * lvar list * exp * exp 29 | and slice = 30 | SGT of exp 31 | | SEQ of { base: exp, start: exp, stop: exp } 32 | (* the boolean flag, when set to true, is a strong 33 | * hint to have this function inlined *) 34 | withtype function = lvar * lvar list * exp * bool 35 | end 36 | -------------------------------------------------------------------------------- /lambda2anf.sml: -------------------------------------------------------------------------------- 1 | (* lambda2anf.sml 2 | * 3 | * Conversion from straight Lambda to ANF. 4 | * 5 | * Copyright (c) 2007 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | structure LambdaToANF : sig 8 | 9 | val convert : Lambda.function -> ANF.function 10 | 11 | end = struct 12 | 13 | structure L = Lambda 14 | structure A = ANF 15 | 16 | fun wt f = f (LVar.new "tmp") (* with temporary *) 17 | fun wc (v, f) = f (LVar.clone v) (* with cloned temporary *) 18 | fun ws (s, f) = f (LVar.new s) (* with named temporary (string) *) 19 | 20 | fun wf (NONE, f) = wt f (* with fresh variable *) 21 | | wf (SOME v, f) = wc (v, f) 22 | 23 | fun cont (NONE, x) = A.VALUES [x] 24 | | cont (SOME k, x) = k x 25 | 26 | fun call (NONE, _, p, a) = A.JUMP (p, a) 27 | | call (SOME k, v0, p, a) = 28 | wf (v0, fn v => A.CALL (p, [v], a, k (A.VAR v))) 29 | 30 | fun ijump f xl = A.JUMP (Purity.Impure, (A.VAR f, xl)) 31 | fun lam (f, vl, b, i, h) = { f = (f, vl, b), inl = i, hdlr = h } 32 | 33 | fun joinpt (NONE, _, b) = b NONE 34 | | joinpt (SOME k, v0, b) = 35 | wt (fn f => wf (v0, fn v => 36 | A.FIX ([lam (f, [v], k (A.VAR v), false, false)], 37 | b (SOME (fn x => ijump f [x]))))) 38 | 39 | fun list f ([], k) = k [] 40 | | list f (h :: t, k) = f (h, fn h' => list f (t, fn t' => k (h' :: t'))) 41 | 42 | fun exp (L.VALUE v, _, k) = cont (k, v) 43 | | exp (L.LET (v, e, b), v0, k) = 44 | exp (e, SOME v, SOME (fn x => A.BIND (v, x, exp (b, v0, k)))) 45 | | exp (L.FIX (fl, b), v0, k) = 46 | A.FIX (map convert fl, exp (b, v0, k)) 47 | | exp (L.ARITH (aop, e1, e2), v0, k) = 48 | wf (v0, fn v => ex (e1, fn x1 => ex (e2, fn x2 => 49 | A.ARITH (aop, x1, x2, v, cont (k, A.VAR v))))) 50 | | exp (L.RECORD { purity = m, len = e, slices = sl }, v0, k) = 51 | wf (v0, fn v => ex (e, fn x => 52 | list slice (sl, fn sl' => 53 | A.RECORD (m, x, sl', v, cont (k, A.VAR v))))) 54 | | exp (L.SELECT (e1, e2, m), v0, k) = 55 | wf (v0, fn v => ex (e1, fn x1 => ex (e2, fn x2 => 56 | A.SELECT (x1, x2, m, v, cont (k, A.VAR v))))) 57 | | exp (L.UPDATE (e1, e2, e3), _, k) = 58 | ex (e1, fn x1 => ex (e2, fn x2 => ex (e3, fn x3 => 59 | A.UPDATE (x1, x2, x3, cont (k, A.INT 0))))) 60 | | exp (L.CMP (cop, e1, e2, et, ef), v0, k) = 61 | wt (fn f => wf (v0, fn v => 62 | joinpt (k, v0, fn k' => 63 | ex (e1, fn x1 => ex (e2, fn x2 => 64 | A.CMP (cop, x1, x2, exp (et, v0, k'), exp (ef, v0, k'))))))) 65 | | exp (L.APP (p, e, el), v0, k) = 66 | wf (v0, fn v => ex (e, fn x => list ex (el, fn xl => 67 | call (k, v0, p, (x, xl))))) 68 | | exp (L.HANDLER (hv, hvl, hb, b), v0, k) = 69 | joinpt (k, v0, fn k' => wc (hv, fn hv' => 70 | A.FIX ([lam (hv', hvl, exp (hb, v0, k'), false, false)], 71 | ws ("sp", fn oldsp => A.GETSP (oldsp, 72 | list wc (hvl, fn hvl' => 73 | A.FIX ([lam (hv, hvl', A.SETSP (A.VAR oldsp, 74 | ijump hv' (map A.VAR hvl')), 75 | false, true)], 76 | A.MAYJUMP (hv, exp (b, v0, k'))))))))) 77 | 78 | and ex (e, k) = exp (e, NONE, SOME k) 79 | 80 | and slice (L.SGT e, k) = ex (e, fn x => k (A.SGT x)) 81 | | slice (L.SEQ { base, start, stop }, k) = 82 | ex (base, fn b => ex (start, fn s => ex (stop, fn p => 83 | k (A.SEQ { base = b, start = s, stop = p })))) 84 | 85 | and convert (f, vl, b, inl) = lam (f, vl, exp (b, NONE, NONE), inl, false) 86 | end 87 | -------------------------------------------------------------------------------- /litdata.sml: -------------------------------------------------------------------------------- 1 | (* litdata.sml 2 | * 3 | * Literal data (32-bit integers) in the MLPolyR compiler. 4 | * 5 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | structure LiteralData = struct 8 | 9 | type integer = Int.int 10 | 11 | val fromInt = Int.fromInt 12 | val toInt = Int.toInt 13 | 14 | val fromString = Int.fromString 15 | val toString = Int.toString 16 | 17 | val compare = Int.compare 18 | 19 | val toLarge = Int.toLarge 20 | end 21 | -------------------------------------------------------------------------------- /lvar.sml: -------------------------------------------------------------------------------- 1 | (* lvar.sml 2 | * 3 | * "Lambda Variables" -- generic temporaries used by Lamda- 4 | * ANF-, and Tree-languages and also as Pseudo-registers in 5 | * ASM code before register allocation. 6 | * 7 | * Where possible we maintain a mapping from lvars to meaningful 8 | * names (wrt. source code). 9 | * 10 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 11 | *) 12 | structure LVar :> sig 13 | 14 | eqtype lvar 15 | type ord_key = lvar 16 | 17 | val compare : lvar * lvar -> order 18 | 19 | structure Set : ORD_SET where type Key.ord_key = ord_key 20 | structure Map : ORD_MAP where type Key.ord_key = ord_key 21 | 22 | val new : string -> lvar 23 | val clone : lvar -> lvar 24 | val toString : lvar -> string 25 | val baseName : lvar -> string 26 | val special : int * string -> lvar 27 | 28 | val dummy : lvar 29 | 30 | val reset : unit -> unit 31 | 32 | end = struct 33 | 34 | fun bug m = ErrorMsg.impossible ("LVar: " ^ m) 35 | 36 | type lvar = int 37 | 38 | structure Set = IntRedBlackSet 39 | structure Map = IntRedBlackMap 40 | 41 | type ord_key = lvar 42 | val compare = Int.compare 43 | 44 | val minvar = 32 45 | 46 | val next = ref minvar 47 | val info : string Map.map ref = ref Map.empty 48 | 49 | fun reset () = (next := minvar; info := Map.empty) 50 | 51 | fun fresh () = let val n = !next in next := n+1; n end 52 | 53 | fun new name = 54 | let val v = fresh () 55 | in info := Map.insert (!info, v, name); v end 56 | 57 | fun clone v = 58 | let val v' = fresh () 59 | in case Map.find (!info, v) of 60 | SOME name => info := Map.insert (!info, v', name) 61 | | NONE => bug "no name recorded"; 62 | v' 63 | end 64 | 65 | fun baseName v = 66 | case Map.find (!info, v) of 67 | SOME name => name 68 | | NONE => bug "no name recorded" 69 | 70 | fun toString v = concat [baseName v, "_", Int.toString v] 71 | 72 | fun special (i, name) = 73 | if i >= 0 andalso i < minvar then 74 | (info := Map.insert (!info, i, name); i) 75 | else raise bug ("bad special: " ^ Int.toString i) 76 | 77 | val dummy = ~1 78 | end 79 | -------------------------------------------------------------------------------- /machspec.sml: -------------------------------------------------------------------------------- 1 | (* machspec.smml 2 | * 3 | * Machine-specific values the compiler needs to be aware of. 4 | * 5 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | structure MachSpec = struct 8 | 9 | val wordSize = 4 : LiteralData.integer 10 | val numArgs = 7 11 | 12 | end 13 | -------------------------------------------------------------------------------- /main.sml: -------------------------------------------------------------------------------- 1 | (* main.sml 2 | * 3 | * Driver routine for MLPolyR compiler. 4 | * 5 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | structure Main : sig 8 | 9 | val compile : 10 | { pclust: bool, pbbt: bool, pigraph: bool, no_ra: bool, pdefs: bool } -> 11 | string * string -> bool 12 | 13 | val main : string * string list -> OS.Process.status 14 | 15 | end = struct 16 | 17 | datatype state = ToAsm | ToTC | ToObj | ToExe 18 | 19 | val rts = "rt/mlpr-rt.o" 20 | 21 | fun remove file = 22 | OS.FileSys.remove file handle _ => () 23 | 24 | fun typecheck { pclust, pbbt, pigraph, no_ra, pdefs } file = 25 | let val (ast, source) = Parse.parse file 26 | in if ErrorMsg.anyErrors (ErrorMsg.errors source) then false 27 | else let val asyn = Elaborate.elaborate 28 | (source, BaseEnv.elabBase, pdefs) ast 29 | in if pclust then 30 | let val { lambda, strings = _} = 31 | Translate.translate (asyn, BaseEnv.transBase) 32 | val res = LambdaInterpreter.eval 33 | Interpreter.runtime 34 | (Interpreter.makeProgram lambda) 35 | val _ = Interpreter.printResult res 36 | in 37 | true 38 | end 39 | else true 40 | end 41 | end 42 | 43 | fun compile cflags (file, asmfile) = 44 | let val (ast, source) = Parse.parse file 45 | in if ErrorMsg.anyErrors (ErrorMsg.errors source) then false 46 | else let val asm_s = TextIO.openOut asmfile 47 | in Compile.compile cflags (ast, source, asm_s) 48 | before TextIO.closeOut asm_s 49 | end 50 | end 51 | 52 | fun main (self, args) = let 53 | 54 | fun complain msg = 55 | TextIO.output (TextIO.stdErr, concat (self :: ": " :: msg)) 56 | 57 | fun system cmd = 58 | if OS.Process.system cmd = OS.Process.success then true 59 | else (complain ["command `", cmd, "' failed\n"]; 60 | false) 61 | 62 | fun assemble (asmfile, objfile) = 63 | system (concat ["as -o ", objfile, " ", asmfile]) 64 | 65 | fun link (objfile, executable) = 66 | system (concat ["cc -o ", executable, " ", 67 | objfile, " ", rts]) 68 | 69 | fun onefile (flags, state, target, file) = let 70 | fun aoe base = 71 | (OS.Path.joinBaseExt { base = base, ext = SOME "s" }, 72 | OS.Path.joinBaseExt { base = base, ext = SOME "o" }, 73 | base) 74 | val (asmfile, objfile, executable) = 75 | case OS.Path.splitBaseExt file of 76 | { base, ext = SOME "mlpr" } => aoe base 77 | | _ => aoe file 78 | in case state of 79 | ToAsm => compile flags (file, getOpt (target, asmfile)) 80 | | ToTC => typecheck flags file 81 | | ToObj => 82 | ((compile flags (file, asmfile) andalso 83 | assemble (asmfile, getOpt (target, objfile))) 84 | before remove asmfile) 85 | | ToExe => 86 | ((((compile flags (file, asmfile) andalso 87 | assemble (asmfile, objfile)) 88 | before remove asmfile) andalso 89 | link (objfile, getOpt (target, executable))) 90 | before remove objfile) 91 | end 92 | 93 | fun setPC { pclust, pbbt, pigraph, no_ra, pdefs } = 94 | { pclust = true, pbbt = pbbt, pigraph = pigraph, 95 | no_ra = no_ra, pdefs = pdefs } 96 | fun setPT { pclust, pbbt, pigraph, no_ra, pdefs } = 97 | { pclust = pclust, pbbt = true, pigraph = pigraph, 98 | no_ra = no_ra, pdefs = pdefs } 99 | fun setSG { pclust, pbbt, pigraph, no_ra, pdefs } = 100 | { pclust = pclust, pbbt = pbbt, pigraph = true, 101 | no_ra = no_ra, pdefs = pdefs } 102 | fun setNORA { pclust, pbbt, pigraph, no_ra, pdefs } = 103 | { pclust = pclust, pbbt = pbbt, pigraph = pigraph, 104 | no_ra = true, pdefs = pdefs } 105 | fun setPD { pclust, pbbt, pigraph, no_ra, pdefs } = 106 | { pclust = pclust, pbbt = pbbt, pigraph = pigraph, 107 | no_ra = no_ra, pdefs = true } 108 | val noflags = 109 | { pclust = false, pbbt = false, pigraph = false, 110 | no_ra = false, pdefs = false } 111 | 112 | fun process (flags, state, _, "-o" :: target :: rest) = 113 | process (flags, state, SOME target, rest) 114 | | process (_, _, _, ["-o"]) = 115 | (complain ["option -o given without argument\n"]; 116 | OS.Process.failure) 117 | | process (flags, _, target, "-S" :: rest) = 118 | process (flags, ToAsm, target, rest) 119 | | process (flags, _, target, "-t" :: rest) = 120 | process (flags, ToTC, target, rest) 121 | | process (flags, _, target, "-e" :: rest) = 122 | process (setPC flags, ToTC, target, rest) 123 | | process (flags, _, target, "-c" :: rest) = 124 | process (flags, ToObj, target, rest) 125 | | process (flags, state, target, "-PC" :: rest) = 126 | process (setPC flags, state, target, rest) 127 | | process (flags, state, target, "-PT" :: rest) = 128 | process (setPT flags, state, target, rest) 129 | | process (flags, state, target, "-SG" :: rest) = 130 | process (setSG flags, state, target, rest) 131 | | process (flags, state, target, "-NORA" :: rest) = 132 | process (setNORA flags, state, target, rest) 133 | | process (flags, state, target, "-PD" :: rest) = 134 | process (setPD flags, state, target, rest) 135 | | process (flags, state, target, file :: rest) = 136 | if onefile (flags, state, target, file) 137 | then process (flags, state, target, rest) 138 | else OS.Process.failure 139 | | process (_, _, _, []) = OS.Process.success 140 | in process (noflags, ToExe, NONE, args) 141 | end handle e => 142 | (TextIO.output (TextIO.stdErr, General.exnMessage e ^ "\n"); 143 | OS.Process.failure) 144 | end 145 | -------------------------------------------------------------------------------- /makegraph.sml: -------------------------------------------------------------------------------- 1 | (* makegraph.sml 2 | * 3 | * Build flowgraph from instruction list for subsequent use by 4 | * liveness analyses. 5 | * 6 | * This code is based on Andrew Appel's book "Modern Compiler 7 | * Implementation in ML". 8 | *) 9 | structure MakeGraph : sig 10 | val instrs2graph: Asm.instr list -> Flow.flowgraph * Graph.node list 11 | end = struct 12 | 13 | fun bug m = ErrorMsg.impossible ("MakeGraph: " ^ m) 14 | 15 | structure F = Flow 16 | structure G = F.Graph 17 | structure A = Asm 18 | structure T = G.Map 19 | structure TS = LVar.Set 20 | structure LM = Label.Map 21 | 22 | fun add (t, n, l) = foldl (fn (x, t) => T.insert (t, n, x)) t l 23 | 24 | fun instrs2graph instrs = let 25 | val g = G.newGraph () 26 | val nl = map (fn _ => G.newNode g) instrs 27 | fun regLab (A.LABEL lab, n, lmap) = LM.insert (lmap, lab, n) 28 | | regLab (_, _, lmap) = lmap 29 | val lmap = ListPair.foldl regLab LM.empty (instrs, nl) 30 | val empty = TS.empty 31 | val single = TS.singleton 32 | fun set l = TS.addList (empty, l) 33 | 34 | fun mkEdges ([], [], use, def, ismove) = (use, def, ismove) 35 | | mkEdges (hi :: ti, hn :: tn, use, def, ismove) = 36 | let fun edges ll = 37 | let fun edge l = 38 | case LM.find (lmap, l) of 39 | NONE => bug "bad label" 40 | | SOME n => G.mk_edge { from = hn, to = n } 41 | in app edge ll 42 | end 43 | fun defedge sn = G.mk_edge { from = hn, to = sn } 44 | fun continue (u, d, im) = 45 | mkEdges (ti, tn, 46 | T.insert (use, hn, u), 47 | T.insert (def, hn, d), 48 | T.insert (ismove, hn, im)) 49 | fun fst (sn :: _) = sn 50 | | fst [] = bug "mkEdges(1)" 51 | in case hi of 52 | A.OPER { jmp = A.RETURN, src, ... } => 53 | continue (set src, empty, false) 54 | | A.OPER { src, dst, jmp = A.JUMP ll, ... } => 55 | (edges ll; 56 | continue (set src, set dst, false)) 57 | | A.LABEL _ => 58 | (defedge (fst tn); 59 | continue (empty, empty, false)) 60 | | A.OPER { src, dst, jmp = A.NOJUMP, ... } => 61 | (defedge (fst tn); 62 | continue (set src, set dst, false)) 63 | | A.MOVE { src, dst, ... } => 64 | (defedge (fst tn); 65 | continue (single src, single dst, true)) 66 | | A.REGSAVE => 67 | (defedge (fst tn); 68 | continue (set Frame.calleesaves, empty, false)) 69 | | A.REGRESTORE => 70 | (defedge (fst tn); 71 | continue (empty, set Frame.calleesaves, false)) 72 | | A.NOSTACK => 73 | ( (* eventually we need to convey this info to 74 | * the RA *) 75 | defedge (fst tn); 76 | continue (empty, empty, false)) 77 | end 78 | | mkEdges _ = bug "mkEdges(2)" 79 | 80 | val (use, def, ismove) = 81 | mkEdges (instrs, nl, T.empty, T.empty, T.empty) 82 | in (F.FGRAPH { control = g, def = def, use = use, ismove = ismove }, nl) 83 | end 84 | end 85 | -------------------------------------------------------------------------------- /mlpolyr.cm: -------------------------------------------------------------------------------- 1 | (* mlpolyr.cm 2 | * 3 | * CM description file for MLPolyR compiler. 4 | * 5 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | Library 8 | functor MLPolyRLrValsFun 9 | functor MLPolyRLexFun 10 | structure Oper 11 | structure Ast 12 | structure Types 13 | structure Unify 14 | structure Absyn 15 | structure Elaborate 16 | structure Parse 17 | structure Lambda 18 | structure Translate 19 | structure ANF 20 | structure LambdaToANF 21 | structure ANFOpt 22 | structure Closed 23 | structure Closure 24 | structure FunctionClusters 25 | structure PrintClusters 26 | structure TreeOps 27 | structure BBTree 28 | structure Frame 29 | structure Treeify 30 | structure ValueNumbering 31 | structure TraceTree 32 | structure TraceSchedule 33 | structure Asm 34 | structure PPCCodeGen 35 | structure ExternalAccess 36 | structure BaseEnv 37 | 38 | structure LambdaInterpreter 39 | structure ANFInterpreter 40 | 41 | structure Graph 42 | structure Flow 43 | structure MakeGraph 44 | structure Liveness 45 | structure Color 46 | structure Rewrite 47 | structure RegAlloc 48 | structure Compile 49 | structure Main 50 | is 51 | $/basis.cm 52 | $/ml-yacc-lib.cm 53 | $/smlnj-lib.cm 54 | $smlnj/viscomp/basics.cm 55 | 56 | $smlnj-tdp/back-trace.cm 57 | 58 | machspec.sml 59 | 60 | symbol.sml 61 | oper.sml 62 | litdata.sml 63 | mlpolyr.grm 64 | mlpolyr.lex 65 | reclab.sml 66 | ast.sml 67 | tvar.sml 68 | types.sml 69 | typesutil.sml 70 | unify.sml 71 | absyn.sml 72 | extacc.sml 73 | baseenv.sml 74 | elaborate.sml 75 | env.sml 76 | parse.sml 77 | lvar.sml 78 | purity.sml 79 | label.sml 80 | lambda.sml 81 | translate.sml 82 | anf.sml 83 | pranf.sml 84 | lambda2anf.sml 85 | anf-opt.sml 86 | flatten.sml 87 | uncurry.sml 88 | 89 | lambda-interpreter.sml 90 | anf-interpreter.sml 91 | interp.sml 92 | 93 | closed.sml 94 | closure.sml 95 | fclusters.sml 96 | prfclusters.sml 97 | value-numbering.sml 98 | 99 | treeops.sml 100 | bbtree.sml 101 | frame.sml 102 | treeify.sml 103 | tracetree.sml 104 | traceschedule.sml 105 | 106 | asm.sml 107 | cg.sml 108 | 109 | prbbtree.sml 110 | 111 | graph.sig 112 | graph.sml 113 | flowgraph.sml 114 | makegraph.sml 115 | liveness.sml 116 | color.sml 117 | rewrite.sml 118 | ra.sml 119 | compile.sml 120 | main.sml 121 | 122 | notyet.sml 123 | -------------------------------------------------------------------------------- /mlpolyr.lex: -------------------------------------------------------------------------------- 1 | (* -*- sml-lex -*- 2 | * mlpolyr.lex 3 | * 4 | * The lexer for the MLPolyR compiler (as ML-Lex specification). 5 | * 6 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 7 | *) 8 | 9 | structure T = Tokens 10 | structure E = ErrorMsg 11 | 12 | type pos = int 13 | type svalue = T.svalue 14 | type ('a, 'b) token = ('a, 'b) T.token 15 | type lexresult = (svalue,pos) token 16 | 17 | type lexarg = { enterC : unit -> unit, 18 | leaveC : unit -> bool, 19 | newS : pos -> unit, 20 | addS : char -> unit, 21 | getS : pos -> string * pos * pos, 22 | handleEof : unit -> pos, 23 | newline : pos -> unit, 24 | error : pos * pos -> string -> unit } 25 | 26 | type arg = lexarg 27 | 28 | fun eof (arg: lexarg) = 29 | let val pos = #handleEof arg () 30 | in T.EOF (pos, pos) 31 | end 32 | 33 | local 34 | val idlist = [("andalso", T.KW_andalso), 35 | ("orelse", T.KW_orelse), 36 | ("if", T.KW_if), 37 | ("then", T.KW_then), 38 | ("else", T.KW_else), 39 | ("false", T.KW_false), 40 | ("true", T.KW_true), 41 | ("let", T.KW_let), 42 | ("in", T.KW_in), 43 | ("end", T.KW_end), 44 | ("fun", T.KW_fun), 45 | ("and", T.KW_and), 46 | ("val", T.KW_val), 47 | ("fn", T.KW_fn), 48 | ("match", T.KW_match), 49 | ("with", T.KW_with), 50 | ("cases", T.KW_cases), 51 | ("default", T.KW_default), 52 | ("nocases", T.KW_nocases), 53 | ("as", T.KW_as), 54 | ("where", T.KW_where), 55 | ("case", T.KW_case), 56 | ("of", T.KW_of), 57 | ("handling", T.KW_handling), 58 | ("rehandling", T.KW_rehandling), 59 | ("try", T.KW_try), 60 | ("raise", T.KW_raise), 61 | ("isnull", T.KW_isnull), 62 | ("not", T.KW_not)] 63 | 64 | in 65 | fun idToken (t, p) = 66 | case List.find (fn (id, _) => id = t) idlist of 67 | NONE => T.NAME (Symbol.atom t, p, p + size t) 68 | | SOME (_, tok) => tok (p, p + size t) 69 | end 70 | 71 | val maxsmallnum = LiteralData.fromInt (getOpt (Int.maxInt, 0xffff)) 72 | 73 | %% 74 | %s COMMENT STRING; 75 | %header (functor MLPolyRLexFun (structure Tokens: MLPolyR_TOKENS)); 76 | %arg ({ enterC, leaveC, newS, addS, getS, handleEof, newline, error }); 77 | 78 | letter=[a-zA-Z]; 79 | letdig=[a-zA-Z0-9_']; 80 | digit=[0-9]; 81 | white=[\ \t\r\f]; 82 | 83 | 84 | %% 85 | 86 | "(*" => (enterC (); continue ()); 87 | "*)" => (if leaveC () then YYBEGIN INITIAL else (); continue ()); 88 | "\n" => (newline yypos; continue ()); 89 | . => (continue ()); 90 | "(*" => (YYBEGIN COMMENT; enterC (); continue ()); 91 | "*)" => (error (yypos, yypos + 2) "unmatched comment delimiter"; 92 | continue ()); 93 | {letter}{letdig}* => (idToken (yytext, yypos)); 94 | "_" => (T.WILD (yypos, yypos + 1)); 95 | "(" => (T.LP (yypos, yypos + 1)); 96 | ")" => (T.RP (yypos, yypos + 1)); 97 | "{" => (T.LCB (yypos, yypos + 1)); 98 | "}" => (T.RCB (yypos, yypos + 1)); 99 | "[" => (T.LSB (yypos, yypos + 1)); 100 | "]" => (T.RSB (yypos, yypos + 1)); 101 | "{|" => (T.LCBB (yypos, yypos + 2)); 102 | "|}" => (T.RCBB (yypos, yypos + 2)); 103 | "==" => (T.DEQ (yypos, yypos + 2)); 104 | "<=" => (T.LTEQ (yypos, yypos + 2)); 105 | "<" => (T.LT (yypos, yypos + 1)); 106 | ">=" => (T.GTEQ (yypos, yypos + 2)); 107 | ">" => (T.GT (yypos, yypos + 1)); 108 | "<>" => (T.NEQ (yypos, yypos + 2)); 109 | "::" => (T.DCOLON (yypos, yypos + 1)); 110 | "+" => (T.PLUS (yypos, yypos + 1)); 111 | "-" => (T.MINUS (yypos, yypos + 1)); 112 | "*" => (T.TIMES (yypos, yypos + 1)); 113 | "/" => (T.DIV (yypos, yypos + 1)); 114 | "%" => (T.MOD (yypos, yypos + 1)); 115 | "=" => (T.EQ (yypos, yypos + 1)); 116 | "." => (T.DOT (yypos, yypos + 1)); 117 | "," => (T.COMMA (yypos, yypos + 1)); 118 | ";" => (T.SEMI (yypos, yypos + 1)); 119 | "!" => (T.EXCLAM (yypos, yypos + 1)); 120 | "`" => (T.BQ (yypos, yypos + 1)); 121 | "++" => (T.PLUSPLUS (yypos, yypos + 2)); 122 | ":=" => (T.ASSIGN (yypos, yypos + 2)); 123 | "|" => (T.BAR (yypos, yypos + 1)); 124 | "=>" => (T.DARROW (yypos, yypos + 2)); 125 | ":" => (T.COLON (yypos, yypos + 1)); 126 | "..." => (T.DOTDOTDOT (yypos, yypos + 3)); 127 | {digit}+ => (let val n = valOf (LiteralData.fromString yytext) 128 | val st = yypos val en = yypos + size yytext 129 | in if 1 <= n andalso n <= maxsmallnum then 130 | T.SMALLNUM (LiteralData.toInt n, st, en) 131 | else T.NUMBER (n, st, en) 132 | end 133 | handle _ => (error (yypos, yypos + size yytext) 134 | "integer literal too large"; 135 | continue ())); 136 | \n => (newline yypos; continue ()); 137 | {white} => (continue ()); 138 | "\"" => (YYBEGIN STRING; newS yypos; continue ()); 139 | "\\n" => (addS #"\n"; continue ()); 140 | "\\t" => (addS #"\t"; continue ()); 141 | "\\\"" => (addS #"\""; continue ()); 142 | "\\\\" => (addS #"\\"; continue ()); 143 | "\\". => (error (yypos, yypos+1) 144 | ("illegal escape character in STRING " ^ yytext); 145 | continue ()); 146 | "\"" => (YYBEGIN INITIAL; T.STRING (getS yypos)); 147 | \n => (error (yypos, yypos+1) "illegal linebreak in STRING"; 148 | continue ()); 149 | . => (addS (String.sub (yytext, 0)); continue ()); 150 | . => (error (yypos, yypos) 151 | ("illegal character " ^ yytext); 152 | continue ()); 153 | -------------------------------------------------------------------------------- /mlpolyrc: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | sml @SMLload=mlpolyr "$@" 4 | -------------------------------------------------------------------------------- /notyet.sml: -------------------------------------------------------------------------------- 1 | structure Not = struct 2 | 3 | fun yet () = raise Fail "notyet" 4 | 5 | end 6 | -------------------------------------------------------------------------------- /oper.sml: -------------------------------------------------------------------------------- 1 | (* oper.sml 2 | * 3 | * (Source-level) arithmetic- and comparison operators for MLPolyR. 4 | * 5 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | structure Oper = struct 8 | 9 | datatype cmpop = 10 | EQ 11 | | LTEQ 12 | | LT 13 | | GTEQ 14 | | GT 15 | | NEQ 16 | 17 | datatype arithop = 18 | PLUS 19 | | MINUS 20 | | TIMES 21 | | DIV 22 | | MOD 23 | 24 | fun purearith PLUS = true 25 | | purearith MINUS = true 26 | | purearith TIMES = true 27 | | purearith DIV = false 28 | | purearith MOD = false 29 | 30 | fun commutative PLUS = true 31 | | commutative MINUS = false 32 | | commutative TIMES = true 33 | | commutative DIV = false 34 | | commutative MOD = false 35 | 36 | fun doarith (PLUS, x: LiteralData.integer, y) = x + y 37 | | doarith (MINUS, x, y) = x - y 38 | | doarith (TIMES, x, y) = (x div 2) * (y div 2) * 2 39 | | doarith (DIV, x, y) = ((x div 2) div (y div 2)) * 2 40 | | doarith (MOD, x, y) = x mod y 41 | 42 | fun astring PLUS = "+" 43 | | astring MINUS = "-" 44 | | astring TIMES = "*" 45 | | astring DIV = "/" 46 | | astring MOD = "%" 47 | 48 | fun docmp (EQ, x: LiteralData.integer, y) = x = y 49 | | docmp (LTEQ, x, y) = x <= y 50 | | docmp (LT, x, y) = x < y 51 | | docmp (GTEQ, x, y) = x >= y 52 | | docmp (GT, x, y) = x > y 53 | | docmp (NEQ, x, y) = x <> y 54 | 55 | fun cstring EQ = "==" 56 | | cstring LTEQ = "<=" 57 | | cstring LT = "<" 58 | | cstring GTEQ = ">=" 59 | | cstring GT = ">" 60 | | cstring NEQ = "<>" 61 | end 62 | -------------------------------------------------------------------------------- /parse.sml: -------------------------------------------------------------------------------- 1 | (* parse.sml 2 | * 3 | * Driver code for MLPolyR's ML-Yacc/ML-Lex-based parser. 4 | * 5 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | structure Parse : sig 8 | val parse : string -> Ast.program * Source.inputSource 9 | end = struct 10 | structure MLPolyRLrVals = 11 | MLPolyRLrValsFun (structure Token = LrParser.Token) 12 | structure Lex = 13 | MLPolyRLexFun (structure Tokens = MLPolyRLrVals.Tokens) 14 | structure MLPolyRP = 15 | JoinWithArg (structure ParserData = MLPolyRLrVals.ParserData 16 | structure Lex=Lex 17 | structure LrParser = LrParser) 18 | 19 | val errcons = ErrorMsg.defaultConsumer () 20 | 21 | fun parse filename = 22 | let val _ = LVar.reset () 23 | val _ = Label.reset () 24 | val file = TextIO.openIn filename 25 | val source = Source.newSource (filename, file, false, errcons) 26 | val sm = #sourceMap source 27 | fun error r m = 28 | ErrorMsg.error source r ErrorMsg.COMPLAIN m 29 | ErrorMsg.nullErrorBody 30 | val depth = ref 0 31 | fun enterC () = depth := !depth + 1 32 | fun leaveC () = let val d = !depth - 1 in depth := d; d = 0 end 33 | fun newline pos = SourceMap.newline sm pos 34 | 35 | val curstring = ref [] 36 | val startpos = ref 0 37 | val instring = ref false 38 | fun newS sp = (startpos := sp; curstring := []; instring := true) 39 | fun addS c = curstring := c :: !curstring 40 | fun getS ep = (instring := false; 41 | (String.implode (rev (!curstring)), !startpos, ep)) 42 | 43 | fun handleEof () = let 44 | val pos = SourceMap.lastLinePos sm 45 | in if !depth > 0 then 46 | error (pos, pos) "unexpected end of input in comment" 47 | else if !instring then 48 | error (pos, pos) "unexpected end of input in string literal" 49 | else (); 50 | Source.closeSource source; 51 | pos 52 | end 53 | fun get _ = TextIO.input file 54 | val lexarg = 55 | { enterC = enterC, leaveC = leaveC, 56 | newS = newS, addS = addS, getS = getS, 57 | handleEof = handleEof, 58 | newline = newline, 59 | error = error } 60 | val lexer = MLPolyRP.makeLexer get lexarg 61 | val (ast, _) = MLPolyRP.parse 62 | (30,lexer, 63 | fn (s, p, p') => error (p, p') s, 64 | ()) 65 | in (ast, source) 66 | end handle LrParser.ParseError => raise ErrorMsg.Error 67 | end 68 | -------------------------------------------------------------------------------- /pranf.sml: -------------------------------------------------------------------------------- 1 | (* pranf.sml 2 | * 3 | * Pretty-printing ANF. 4 | * 5 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | structure PrintANF : sig 8 | 9 | val exp : (string -> unit) -> ANF.exp -> unit 10 | val function : (string -> unit) -> ANF.function -> unit 11 | val value : (string -> unit) -> ANF.value -> unit 12 | 13 | end = struct 14 | 15 | structure A = ANF 16 | structure O = Oper 17 | 18 | fun var pr v = pr (LVar.toString v) 19 | 20 | fun value pr (A.VAR v) = var pr v 21 | | value pr (A.LABEL l) = pr (Label.name l) 22 | | value pr (A.INT i) = pr (LiteralData.toString i) 23 | 24 | fun list pr f [] = () 25 | | list pr f [x] = f x 26 | | list pr f (h :: t) = (f h; pr ","; list pr f t) 27 | 28 | fun spaces pr 0 = () 29 | | spaces pr n = (pr " "; spaces pr (n-1)) 30 | 31 | fun function0 indent pr { f = (f, vl, e), inl, hdlr } = 32 | (spaces pr indent; 33 | var pr f; 34 | if hdlr then pr "!" else (); 35 | pr "("; list pr (var pr) vl; pr ")="; 36 | if inl then pr "=" else (); 37 | exp0 (indent+1) pr e; 38 | pr "\n") 39 | 40 | and exp0 indent pr e = 41 | let fun purity Purity.Pure = () 42 | | purity Purity.Impure = pr "!" 43 | fun ar () = pr " <- " 44 | fun indentation () = spaces pr indent 45 | val var = fn v => var pr v 46 | val value = fn x => value pr x 47 | fun slice (A.SGT x) = value x 48 | | slice (A.SEQ { base, start, stop }) = 49 | (value base; 50 | pr "{"; value start; pr ".."; value stop; pr "}") 51 | fun arithop aop = pr (O.astring aop) 52 | fun cmpop cop = pr (O.cstring cop) 53 | fun exp e = 54 | (pr "\n"; 55 | indentation (); 56 | case e of 57 | A.VALUES xl => (pr "return "; list pr value xl) 58 | | A.BIND (v, x, e) => 59 | (var v; ar (); value x; exp e) 60 | | A.CALL (p, vl, (x, xl), e) => 61 | (list pr var vl; ar (); purity p; 62 | value x; pr "("; list pr value xl; pr ")"; 63 | exp e) 64 | | A.FIX (fl, e) => 65 | (pr "fix\n"; 66 | app (function0 (indent+1) pr) fl; 67 | indentation (); 68 | pr "in"; 69 | exp0 (indent+1) pr e) 70 | | A.ARITH (aop, x, y, v, e) => 71 | (var v; ar (); value x; arithop aop; value y; exp e) 72 | | A.RECORD (p, x, sl, v, e) => 73 | (var v; ar (); purity p; pr "["; 74 | list pr slice sl; pr "]("; value x; pr ")"; 75 | exp e) 76 | | A.SELECT (x, y, p, v, e) => 77 | (var v; ar (); value x; purity p; pr "."; value y; 78 | exp e) 79 | | A.UPDATE (x, y, z, e) => 80 | (value x; pr "."; value y; pr " := "; value z; 81 | exp e) 82 | | A.CMP (cop, x, y, et, ef) => 83 | (pr "if "; value x; cmpop cop; value y; pr " then"; 84 | exp0 (indent+1) pr et; 85 | pr "\n"; indentation (); pr "else"; 86 | exp0 (indent+1) pr ef) 87 | | A.JUMP (p, (x, xl)) => 88 | (pr "goto "; purity p; value x; pr "("; 89 | list pr value xl; pr ")") 90 | | A.GETSP (v, e) => 91 | (var v; ar (); pr "$sp"; exp e) 92 | | A.SETSP (x, e) => 93 | (pr "$sp"; ar (); value x; exp e) 94 | | A.MAYJUMP (v, e) => 95 | (pr "mayjump "; var v; exp e)) 96 | in exp e 97 | end 98 | 99 | fun function pr f = function0 0 pr f 100 | fun exp pr e = exp0 0 pr e 101 | end 102 | -------------------------------------------------------------------------------- /prbbtree.sml: -------------------------------------------------------------------------------- 1 | (* prbbtree.sml 2 | * 3 | * Pretty-printing Basic-Block-Trees. 4 | * 5 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | structure PrintBBTree = struct 8 | 9 | structure B = BBTree 10 | 11 | fun prcluster print { entryblocks, labelblocks } = 12 | let fun nl () = print "\n" 13 | fun temp t = print (LVar.toString t) 14 | fun label l = print (Label.name l) 15 | fun binop bop = print (TreeOps.binop2string bop) 16 | fun relop rop = print (TreeOps.relop2string rop) 17 | fun int i = if i < 0 then 18 | (print "-"; print (LiteralData.toString (~i))) 19 | else print (LiteralData.toString i) 20 | fun sint i = if i < 0 then int i else (print "+"; int i) 21 | fun list f [] = () 22 | | list f [x] = f x 23 | | list f (x :: xs) = (f x; print ","; list f xs) 24 | fun lexp (B.MEM e) = (print "M["; exp e; print "]") 25 | | lexp (B.TEMP t) = temp t 26 | | lexp B.ALLOCPTR = print "$allocptr" 27 | | lexp B.STACKPTR = print "$stackptr" 28 | and exp (B.FETCH le) = lexp le 29 | | exp (B.BINOP (bop, e1, e2)) = 30 | (print "("; exp e1; binop bop; exp e2; print ")") 31 | | exp (B.NAME l) = label l 32 | | exp (B.CONST i) = int i 33 | fun call (k, e, el) = 34 | (print k; print " "; exp e; print "("; 35 | list exp el; print ")") 36 | fun prpreblock (B.JUMP l) = 37 | (print " goto "; label l; nl ()) 38 | | prpreblock (B.TCALL (e, el)) = 39 | (call (" tailcall", e, el); nl ()) 40 | | prpreblock (B.RETURN el) = 41 | (print " return "; list exp el; nl ()) 42 | | prpreblock (B.CJUMP (rop, e1, e2, l1, l2)) = 43 | (print " if "; exp e1; relop rop; exp e2; 44 | print " then goto "; label l1; print " else goto "; 45 | label l2; nl ()) 46 | | prpreblock (B.CALL (lel, e, el, pb)) = 47 | (print " "; list lexp lel; print " <- "; 48 | call ("call", e, el); nl (); prpreblock pb) 49 | | prpreblock (B.MOVE (le, e, pb)) = 50 | (print " "; lexp le; print " <- "; exp e; nl (); 51 | prpreblock pb) 52 | | prpreblock (B.DOCALL (e, el, pb)) = 53 | (print " do "; call ("call", e, el); nl (); prpreblock pb) 54 | | prpreblock (B.DOEXP (e, pb)) = 55 | (print " do "; exp e; nl (); prpreblock pb) 56 | | prpreblock (B.GCTEST (e, pb)) = 57 | (print " *gctest "; exp e; nl (); prpreblock pb) 58 | | prpreblock (B.ALLOCWRITE (e, pb)) = 59 | (print " M[++$allocptr] <- "; exp e; nl (); prpreblock pb) 60 | | prpreblock (B.ALLOCCOPY (frombase, len, pb)) = 61 | (print " for i in [0.."; exp len; 62 | print ") do M[++$allocptr] <- M["; exp frombase; 63 | print "+i]"; nl (); prpreblock pb) 64 | fun prblock (l, pb) = 65 | (label l; print ":"; nl (); prpreblock pb) 66 | fun prentryblock (vl, (l, pb), eh) = 67 | (if eh then print "!" else (); 68 | label l; print "("; list temp vl; print "):"; nl (); 69 | prpreblock pb) 70 | in print "========================================\n"; 71 | app prentryblock entryblocks; 72 | print "----------------------------------------\n"; 73 | app prblock labelblocks 74 | end 75 | end 76 | -------------------------------------------------------------------------------- /prfclusters.sml: -------------------------------------------------------------------------------- 1 | (* prfclusters.sml 2 | * 3 | * Pretty-printing function clusters. 4 | * 5 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | structure PrintClusters : sig 8 | 9 | val print : (string -> unit) -> FunctionClusters.clusters -> unit 10 | 11 | end = struct 12 | 13 | structure C = Closed 14 | 15 | fun print print { clusters, entrylabel } = 16 | let fun indent () = print " " 17 | fun nl () = print "\n" 18 | fun var v = print (LVar.toString v) 19 | fun varlist [] = () 20 | | varlist [v] = var v 21 | | varlist (v :: vl) = (var v; print ","; varlist vl) 22 | fun label l = print (Label.name l) 23 | fun value (C.VAR v) = var v 24 | | value (C.INT i) = print (LiteralData.toString i) 25 | | value (C.LABEL l) = label l 26 | fun valuelist [] = () 27 | | valuelist [x] = value x 28 | | valuelist (x :: xl) = (value x; print ","; valuelist xl) 29 | fun slice (C.SGT x) = value x 30 | | slice (C.SEQ { base, start, stop }) = 31 | (value base; print "["; value start; print ".."; 32 | value stop; print ")") 33 | fun slicelist [] = () 34 | | slicelist [s] = slice s 35 | | slicelist (s :: sl) = (slice s; print ","; slicelist sl) 36 | fun jtarget (x, xl) = 37 | (value x; print "("; valuelist xl; print ")") 38 | fun btarget (l, xl) = 39 | (label l; print "("; valuelist xl; print ")") 40 | fun exp (C.VALUES xl) = 41 | (indent (); print "return "; valuelist xl; nl ()) 42 | | exp (C.BIND (v, x, e)) = 43 | (indent (); value x; print " -> "; var v; nl (); exp e) 44 | | exp (C.CALL (ta, vl, jt, e)) = 45 | (indent (); print (if ta = Purity.Pure then "typcall " 46 | else "call "); 47 | jtarget jt; print " -> "; 48 | varlist vl; nl (); exp e) 49 | | exp (C.ARITH (aop, x, y, v, e)) = 50 | (indent (); value x; print (Oper.astring aop); value y; 51 | print " -> "; var v; nl (); exp e) 52 | | exp (C.RECORD (m, x, sl, v, e)) = 53 | (indent (); if m = Purity.Impure then print "!" else (); 54 | print "{"; value x; print ": "; 55 | slicelist sl; print "} -> "; 56 | var v; nl (); exp e) 57 | | exp (C.SELECT (x, y, m, v, e)) = 58 | (indent (); value x; print "["; 59 | value y; if m = Purity.Impure then print "!" 60 | else (); print "] -> "; 61 | var v; nl (); exp e) 62 | | exp (C.UPDATE (x, y, z, e)) = 63 | (indent (); value x; print "!"; value y; print " := "; 64 | value z; nl (); exp e) 65 | | exp (C.CMP (cop, x, y, btt, btf)) = 66 | (indent (); print "if "; value x; print (Oper.cstring cop); 67 | value y; print " then goto "; btarget btt; 68 | print " else goto "; btarget btf; nl ()) 69 | | exp (C.JUMP jt) = 70 | (indent (); print "goto "; jtarget jt; nl ()) 71 | | exp (C.GETSP (v, e)) = 72 | (indent (); print "$sp -> "; var v; nl (); exp e) 73 | | exp (C.SETSP (x, e)) = 74 | (indent (); value x; print " -> $sp"; nl (); exp e) 75 | | exp (C.MAYJUMP (l, e)) = 76 | (indent (); print "mayjump "; label l; nl (); exp e) 77 | fun block (l, vl, e) = 78 | (label l; print "("; valuelist (map C.VAR vl); print "):"; 79 | nl (); exp e) 80 | fun eblock (l, vl, e, eh) = 81 | (if eh then print "!" else (); block (l, vl, e)) 82 | fun cluster { entryblocks, labelblocks } = 83 | (print "========================================\n"; 84 | app eblock entryblocks; 85 | print "----------------------------------------\n"; 86 | app block labelblocks) 87 | in print "**ENTRYPOINT: "; label entrylabel; nl (); 88 | app cluster clusters 89 | end 90 | end 91 | -------------------------------------------------------------------------------- /purity.sml: -------------------------------------------------------------------------------- 1 | (* purity.sml 2 | * 3 | * A special-purpose boolean type. 4 | * 5 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | structure Purity = struct 8 | 9 | datatype purity = Pure | Impure 10 | end 11 | -------------------------------------------------------------------------------- /ra.sml: -------------------------------------------------------------------------------- 1 | (* ra.sml 2 | * 3 | * A simple graph-coloring register allocator. 4 | * 5 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | structure RegAlloc : sig 8 | val alloc : { showigraph: bool } -> 9 | Asm.instr list * Frame.frame * Frame.register list -> 10 | Asm.instr list * Frame.allocation 11 | end = struct 12 | 13 | fun alloc { showigraph } (il, frame, registers) = let 14 | 15 | fun memberOf l (t: LVar.lvar) = List.exists (fn t' => t=t') l 16 | 17 | fun rewrite (il, spills) = let 18 | (* 19 | val _ = print "spilling:" 20 | val _ = app (fn v => print (" " ^ LVar.toString v)) spills 21 | val _ = print "\n" 22 | *) 23 | in 24 | foldr (Rewrite.rewrite (frame, spills)) [] il 25 | end 26 | 27 | fun try (il, pastSpills) = let 28 | val (fgraph, fgnl) = MakeGraph.instrs2graph il 29 | val { igraph, liveOut } = Liveness.interferenceGraph (fgraph, fgnl) 30 | val Liveness.IGRAPH { gtemp, ... } = igraph 31 | 32 | val _ = if showigraph then 33 | Liveness.show (TextIO.stdErr, 34 | Frame.showTemp Frame.precoloring, 35 | igraph) 36 | else () 37 | 38 | fun spillCost n = 39 | if memberOf pastSpills (gtemp n) then 10000 40 | else 1 41 | 42 | val (allocation, spills) = 43 | Color.color { interference = igraph, 44 | initial = Frame.precoloring, 45 | spillCost = spillCost, 46 | registers = registers } 47 | 48 | fun col t = valOf (LVar.Map.find (allocation, t)) 49 | fun delMove (i as Asm.MOVE { src, dst, ... }, r) = 50 | if col src = col dst then r else i :: r 51 | | delMove (i, r) = i :: r 52 | in case spills of 53 | [] => (foldr delMove [] il, allocation) 54 | | _ => try (rewrite (il, spills), spills @ pastSpills) 55 | end 56 | 57 | in try (il, []) 58 | end 59 | end 60 | -------------------------------------------------------------------------------- /reclab.sml: -------------------------------------------------------------------------------- 1 | (* reclab.sml 2 | * 3 | * Representing MLPolyR record labels. 4 | * 5 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | structure RecordLabel = struct 8 | 9 | type symbol = Symbol.atom 10 | 11 | datatype label = 12 | SYMlab of symbol 13 | | NUMlab of int 14 | | LENlab 15 | 16 | fun compare (NUMlab i, NUMlab i') = Int.compare (i, i') 17 | | compare (LENlab, LENlab) = EQUAL 18 | | compare (_, LENlab) = LESS 19 | | compare (LENlab, _) = GREATER 20 | | compare (NUMlab _, SYMlab _) = LESS 21 | | compare (SYMlab _, NUMlab _) = GREATER 22 | | compare (SYMlab s, SYMlab s') = Symbol.lexCompare (s, s') 23 | 24 | fun same (NUMlab i, NUMlab i') = i = i' 25 | | same (SYMlab s, SYMlab s') = Symbol.sameAtom (s, s') 26 | | same (LENlab, LENlab) = true 27 | | same _ = false 28 | 29 | fun sameField ((l, _), (l', _)) = same (l, l') 30 | 31 | fun gt (l, l') = compare (l, l') = GREATER 32 | 33 | fun sameAs l l' = same (l, l') 34 | fun sameFieldAs f f' = sameField (f, f') 35 | fun hasLab l (l', _) = same (l, l') 36 | 37 | fun toString (NUMlab i) = Int.toString i 38 | | toString (SYMlab s) = Symbol.toString s 39 | | toString LENlab = "$len" 40 | 41 | structure Set = RedBlackSetFn 42 | (type ord_key = label val compare = compare) 43 | 44 | fun toSet sel l = Set.addList (Set.empty, map sel l) 45 | fun sortBy sel l = ListMergeSort.sort (fn (x, y) => gt (sel x, sel y)) l 46 | 47 | structure Map = RedBlackMapFn 48 | (type ord_key = label val compare = compare) 49 | 50 | fun map2set m = 51 | Map.foldli (fn (l, _, s) => Set.add (s, l)) Set.empty m 52 | 53 | fun toMap (ksel, rsel) l = 54 | foldl (fn (x, m) => Map.insert (m, ksel x, rsel x)) Map.empty l 55 | end 56 | -------------------------------------------------------------------------------- /rewrite.sml: -------------------------------------------------------------------------------- 1 | (* rewrite.sml 2 | * 3 | * Instruction rewriting (to account for spills produced by the 4 | * register allocator). 5 | * 6 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 7 | *) 8 | structure Rewrite : sig 9 | 10 | val rewrite : Frame.frame * LVar.lvar list -> 11 | Asm.instr * Asm.instr list -> Asm.instr list 12 | 13 | end = struct 14 | 15 | structure M = LVar.Map 16 | structure A = Asm 17 | 18 | (* Given the frame data structure for the current cluster and 19 | * a list of spilled lvars, construct function that 20 | * maps an instruction to an equivalent list of instructions 21 | * that implement spilling. The constructed function 22 | * also takes the "remaining" instructions as an argument 23 | * so that it can be used in a "fold": *) 24 | fun rewrite (frame, spills) = let 25 | (* figure out stack offsets for the spills: *) 26 | val offsetmap = 27 | foldl (fn (t, m) => M.insert (m, t, Frame.allocSpill frame)) 28 | M.empty spills 29 | 30 | fun offset t = Option.map (Frame.spillOff frame) (M.find (offsetmap, t)) 31 | 32 | (* storing into the stack frame *) 33 | fun store (tmp, off) = 34 | A.OPER { asm = concat ["\tstw `s0,", off, "(`s1)"], 35 | src = [tmp, Frame.sp], dst = [], jmp = A.NOJUMP } 36 | 37 | (* loading from the stack frame *) 38 | fun load (tmp, off) = 39 | A.OPER { asm = concat ["\tlwz `d0,", off, "(`s0)"], 40 | src = [Frame.sp], dst = [tmp], jmp = A.NOJUMP } 41 | 42 | (* utility functions for dealing with spilled destinations 43 | * and sources: *) 44 | fun spillDst dst = 45 | case offset dst of 46 | NONE => (dst, []) 47 | | SOME off => 48 | let val t = LVar.clone dst 49 | in (t, [store (t, off)]) 50 | end 51 | 52 | fun spillDst' (dst, (rl, il)) = 53 | let val (dst', il') = spillDst dst 54 | in (dst' :: rl, il' @ il) 55 | end 56 | 57 | fun spillSrc src = 58 | case offset src of 59 | NONE => (src, []) 60 | | SOME off => 61 | let val t = LVar.clone src 62 | in (t, [load (t, off)]) 63 | end 64 | 65 | fun spillSrc' (src, (rl, il)) = 66 | let val (src', il') = spillSrc src 67 | in 68 | (src' :: rl, il' @ il) 69 | end 70 | 71 | (* do it for one instruction: *) 72 | fun rw (i as (A.LABEL _ | 73 | A.REGSAVE | 74 | A.REGRESTORE | 75 | A.NOSTACK), il) = i :: il 76 | | rw (A.MOVE { src, dst, asm }, il) = 77 | let val (src', il1) = spillSrc src 78 | val (dst', il2) = spillDst dst 79 | in il1 @ A.MOVE { src = src', dst = dst', asm = asm } :: 80 | il2 @ il 81 | end 82 | | rw (i as A.OPER { src, dst, asm = a, jmp = j }, il) = 83 | let val (src', il1) = foldr spillSrc' ([], []) src 84 | val (dst', il2) = foldr spillDst' ([], []) dst 85 | in il1 @ A.OPER { asm = a, src = src', dst = dst', jmp = j } :: 86 | il2 @ il 87 | end 88 | in rw 89 | end 90 | end 91 | -------------------------------------------------------------------------------- /rt/Makefile: -------------------------------------------------------------------------------- 1 | all: mlpr-rt.o 2 | @echo all done 3 | 4 | .c.o: 5 | $(CC) -c -O2 $< 6 | -------------------------------------------------------------------------------- /rt/mlpr-rt-nogc.c: -------------------------------------------------------------------------------- 1 | # include 2 | # include 3 | # include 4 | 5 | # define HEAPSIZE (1024*1024) /* one megabyte */ 6 | 7 | # define BUFSZ 128 8 | 9 | extern int mlpr_entrypoint (void *, void *, void *, void *); 10 | 11 | #define taddr(x) ((void*)(((char *)(void *)&(x))+1)) 12 | #define untag(x,t) ((t*)(((char*)(void*)(x))-1)) 13 | 14 | #define boxInt(i) ((i)<<1) 15 | #define unboxInt(i) ((i)>>1) 16 | 17 | struct cons { 18 | void *car; 19 | void *cdr; 20 | }; 21 | 22 | int main (int argc, char **argv) 23 | { 24 | char *heap, *limit; 25 | struct cons *arglist; 26 | int i; 27 | 28 | heap = malloc (HEAPSIZE); 29 | if (heap == NULL) { 30 | fputs ("cannot obtain heap\n", stderr); 31 | return 1; 32 | } 33 | limit = heap + HEAPSIZE; 34 | 35 | if (argc > 1) { 36 | arglist = malloc ((argc - 1) * sizeof (struct cons)); 37 | if (arglist == NULL) { 38 | fputs ("cannot allocate argument list\n", stderr); 39 | return 1; 40 | } 41 | 42 | for (i = 1; i < argc; i++) { 43 | arglist[i-1].car = argv[i]; 44 | arglist[i-1].cdr = taddr(arglist[i]); 45 | } 46 | arglist[argc-2].cdr = NULL; 47 | } 48 | else 49 | arglist = NULL; 50 | 51 | return mlpr_entrypoint (argv[0], (arglist == NULL) ? NULL : taddr(arglist[0]), heap, limit); 52 | } 53 | 54 | struct fun { 55 | void *(*f) (void *, void *); 56 | void *c; 57 | }; 58 | 59 | static void *String_compare (void *cl, void *vp) 60 | { 61 | char **p = untag(vp,char*); 62 | int res = strcmp (p[0], p[1]); 63 | return (void *) boxInt (res); 64 | } 65 | 66 | static struct fun compare_fun = { String_compare, NULL }; 67 | 68 | static void *String_concat (void *cl, void *vl) 69 | { 70 | void *l; 71 | size_t len, p; 72 | char *r; 73 | 74 | 75 | for (l = vl, len = 0; l != NULL; l = untag(l,struct cons)->cdr) 76 | len += strlen (untag(l,struct cons)->car); 77 | r = malloc (len + 1); 78 | if (r == NULL) { 79 | fputs ("String.concat: cannot allocate\n", stderr); 80 | exit(1); 81 | } 82 | for (l = vl, p = 0; l != NULL; l = untag(l,struct cons)->cdr) { 83 | strcpy (r+p, untag(l,struct cons)->car); 84 | p += strlen (untag(l,struct cons)->car); 85 | } 86 | return r; 87 | } 88 | 89 | static struct fun concat_fun = { String_concat, NULL }; 90 | 91 | static void *String_fromInt (void *cl, void *vi) 92 | { 93 | int i = unboxInt ((int)vi); 94 | char *s = malloc (12); 95 | if (s == NULL) { 96 | fputs ("String.fromInt: cannot allocate\n", stderr); 97 | exit (1); 98 | } 99 | sprintf (s, "%d", i); 100 | return s; 101 | } 102 | 103 | static struct fun fromInt_fun = { String_fromInt, NULL }; 104 | 105 | struct dynbuf { 106 | size_t sz; 107 | size_t top; 108 | char *buf; 109 | }; 110 | 111 | static void init_dynbuf (struct dynbuf *db) 112 | { 113 | db->sz = db->top = 0; 114 | db->buf = NULL; 115 | } 116 | 117 | static void dyn_push (struct dynbuf *db, char c) 118 | { 119 | if (db->top >= db->sz) { 120 | db->sz += BUFSZ; 121 | db->buf = realloc (db->buf, db->sz); 122 | if (db->buf == NULL) { 123 | fputs ("String.inputLine: cannot allocate\n", stderr); 124 | exit (1); 125 | } 126 | } 127 | db->buf[db->top++] = c; 128 | } 129 | 130 | static void *String_inputLine (void *cl, void *vs) 131 | { 132 | struct dynbuf db; 133 | int c; 134 | 135 | init_dynbuf (&db); 136 | while ((c = getchar ()) != EOF) { 137 | dyn_push (&db, c); 138 | if (c == '\n') 139 | break; 140 | } 141 | dyn_push (&db, '\0'); /* this guarantees that result won't be NULL */ 142 | return db.buf; 143 | } 144 | 145 | static struct fun inputLine_fun = { String_inputLine, NULL }; 146 | 147 | static void *String_output (void *cl, void *vs) 148 | { 149 | char *s = vs; 150 | fputs (s, stdout); 151 | fflush (stdout); 152 | return 0; 153 | } 154 | 155 | static struct fun output_fun = { String_output, NULL }; 156 | 157 | static void *String_size (void *cl, void *vs) 158 | { 159 | char *s = vs; 160 | return (void *) boxInt (strlen (s)); 161 | } 162 | 163 | static struct fun size_fun = { String_size, NULL }; 164 | 165 | static void *String_sub (void *cl, void *vp) 166 | { 167 | struct { char *s; int i; } *p = untag(vp,void); 168 | return (void *) boxInt ((int) p->s[unboxInt(p->i)]); 169 | } 170 | 171 | static struct fun sub_fun = { String_sub, NULL }; 172 | 173 | static void *String_substring (void *cl, void *vt) 174 | { 175 | struct { char *s; int start; int len; } *t = untag(vt,void); 176 | int len = unboxInt (t->len); 177 | char *res = malloc (len+1); 178 | if (res == NULL) { 179 | fputs ("String.substring: cannot allocate\n", stderr); 180 | exit (1); 181 | } 182 | strncpy (res, t->s + unboxInt (t->start), len); 183 | res[len+1] = '\0'; 184 | return res; 185 | } 186 | 187 | static struct fun substring_fun = { String_substring, NULL }; 188 | 189 | static void *String_toInt (void *cl, void *vs) 190 | { 191 | return (void *) boxInt (atoi ((char *)vs)); 192 | } 193 | 194 | static struct fun toInt_fun = { String_toInt, NULL }; 195 | 196 | struct fun *builtin_mlpr_String[] = 197 | { taddr(compare_fun), 198 | taddr(concat_fun), 199 | taddr(fromInt_fun), 200 | taddr(inputLine_fun), 201 | taddr(output_fun), 202 | taddr(size_fun), 203 | taddr(sub_fun), 204 | taddr(substring_fun), 205 | taddr(toInt_fun) 206 | }; 207 | 208 | void mlpr_gc (void) 209 | { 210 | fputs ("heap exhausted!\n", stderr); 211 | exit (1); 212 | } 213 | -------------------------------------------------------------------------------- /symbol.sml: -------------------------------------------------------------------------------- 1 | (* symbol.sml 2 | * 3 | * Using atoms as symbols (but don't confuse the symbol type with 4 | * the atom type). 5 | * 6 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 7 | *) 8 | structure Symbol :> sig 9 | include ATOM 10 | structure Map : ORD_MAP where type Key.ord_key = atom 11 | structure Set : ORD_SET where type Key.ord_key = atom 12 | end = struct 13 | open Atom 14 | structure Set = AtomRedBlackSet 15 | structure Map = AtomRedBlackMap 16 | end 17 | -------------------------------------------------------------------------------- /traceschedule.sml: -------------------------------------------------------------------------------- 1 | (* traceschedule.sml 2 | * 3 | * Trace-scheduling basic blocks. 4 | * This code is based on Andrew Appel's book "Modern Compiler 5 | * Implementation in ML". 6 | * 7 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 8 | *) 9 | structure TraceSchedule : sig 10 | 11 | val schedule : BBTree.cluster -> TraceTree.entrytrace 12 | 13 | end = struct 14 | 15 | structure L = Label 16 | structure M = L.Map 17 | structure B = BBTree 18 | structure T = TraceTree 19 | 20 | type label = Label.label 21 | 22 | fun bug m = ErrorMsg.impossible ("TraceSchedule: " ^ m) 23 | 24 | fun schedule { entryblocks, labelblocks } = 25 | let fun adde ((vl, (l, b), eh), m) = M.insert (m, l, (SOME (vl,eh), b)) 26 | fun addl ((l, b), m) = M.insert (m, l, (NONE, b)) 27 | val table = foldl addl (foldl adde M.empty entryblocks) labelblocks 28 | 29 | fun findjt (table, l) = 30 | case M.find (table, l) of 31 | NONE => NONE 32 | | SOME (NONE, b) => SOME b 33 | | SOME (SOME _, _) => bug "(c)jump to entry point" 34 | 35 | fun mktrace (table, (l, b), q) = 36 | let val table = #1 (M.remove (table, l)) 37 | fun build (B.JUMP l') = 38 | (case findjt (table, l') of 39 | NONE => T.JUMP (l', more (table, q)) 40 | | SOME b' => 41 | T.LABEL (mktrace (table, (l', b'), q))) 42 | | build (B.TCALL (e, el)) = 43 | T.TCALL (e, el, more (table, q)) 44 | | build (B.RETURN e) = 45 | T.RETURN (e, more (table, q)) 46 | | build (B.CJUMP (r, e1, e2, t, f)) = 47 | (case findjt (table, f) of 48 | NONE => 49 | (case findjt (table, t) of 50 | NONE => 51 | T.CJUMP (r, e1, e2, t, 52 | (Label.new NONE, 53 | T.JUMP (f, more (table, q)))) 54 | | SOME b' => 55 | T.CJUMP (TreeOps.notRel r, e1, e2, f, 56 | mktrace (table, (t, b'), q))) 57 | | SOME b' => 58 | T.CJUMP (r, e1, e2, t, 59 | mktrace (table, (f, b'), t :: q))) 60 | | build (B.MOVE (le, e, b')) = 61 | T.MOVE (le, e, build b') 62 | | build (B.CALL (lel, e, el, b')) = 63 | T.CALL (lel, e, el, build b') 64 | | build (B.DOEXP (e, b')) = 65 | T.DOEXP (e, build b') 66 | | build (B.DOCALL (e, el, b')) = 67 | T.DOCALL (e, el, build b') 68 | | build (B.GCTEST (e, b')) = 69 | T.GCTEST (e, build b') 70 | | build (B.ALLOCWRITE (e, b')) = 71 | T.ALLOCWRITE (e, build b') 72 | | build (B.ALLOCCOPY (frombase, len, b')) = 73 | T.ALLOCCOPY (frombase, len, build b') 74 | in (l, build b) 75 | end 76 | 77 | and more (_, []) = T.END 78 | | more (table, l :: rest) = 79 | case M.find (table, l) of 80 | SOME (SOME (vl, eh), b) => 81 | T.ENTRY (vl, mktrace (table, (l, b), rest), eh) 82 | | SOME (NONE, b) => 83 | T.JTARGET (mktrace (table, (l, b), rest)) 84 | | NONE => 85 | more (table, rest) 86 | in case entryblocks of 87 | (vl, eb, eh) :: ebs => 88 | (vl, mktrace (table, eb, map (#1 o #2) ebs), eh) 89 | | _ => bug "no entry block" 90 | end 91 | end 92 | -------------------------------------------------------------------------------- /tracetree.sml: -------------------------------------------------------------------------------- 1 | (* tracetree.sml 2 | * 3 | * Basic blocks with trees arranged into "traces". 4 | * 5 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | structure TraceTree = struct 8 | 9 | type temp = LVar.lvar 10 | type label = Label.label 11 | 12 | datatype exp = datatype BBTree.exp 13 | datatype lexp = datatype BBTree.lexp 14 | 15 | datatype trace = 16 | LABEL of labtrace (* labeled trace *) 17 | | JUMP of label * newstart (* unconditional jump followed by 18 | * unrelated code *) 19 | | TCALL of exp * exp list * newstart (* tail call followed by 20 | * unrelated code *) 21 | | RETURN of exp list * newstart (* function return followed by 22 | * unrelated code *) 23 | | CJUMP of TreeOps.relop * exp * exp * label * labtrace 24 | (* conditional jump (if condition true), 25 | * fall through to labeled trace when false*) 26 | | CALL of lexp list * exp * exp list * trace (* call w/ multi-result *) 27 | | MOVE of lexp * exp * trace (* assignment followed by trace *) 28 | | DOEXP of exp * trace (* eval. for effect, followed by trace *) 29 | | DOCALL of exp * exp list * trace (* eval call for effect *) 30 | | GCTEST of exp * trace (* make sure there is space available *) 31 | | ALLOCWRITE of exp * trace (* allocate one word *) 32 | | ALLOCCOPY of exp * exp * trace (* allocate a sequence of words 33 | * by copying *) 34 | 35 | and newstart = 36 | END (* no more code *) 37 | | JTARGET of labtrace (* a target for a jump *) 38 | | ENTRY of entrytrace (* a function entry point *) 39 | 40 | withtype labtrace = label * trace 41 | 42 | and entrytrace = temp list * labtrace * bool (* true: exn hdlr *) 43 | end 44 | -------------------------------------------------------------------------------- /treeops.sml: -------------------------------------------------------------------------------- 1 | (* treeops.sml 2 | * 3 | * Arithmetic and relational operations used in trees. 4 | * 5 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | structure TreeOps = struct 8 | 9 | datatype binop = 10 | PLUS | MINUS | MUL | DIV | MOD 11 | | AND | OR | LSHIFT | RSHIFT | ARSHIFT | XOR 12 | 13 | datatype relop = 14 | EQ | NE | LT | GT | LE | GE 15 | | ULT | ULE | UGT | UGE 16 | 17 | fun binop2string PLUS = "+" 18 | | binop2string MINUS = "-" 19 | | binop2string MUL = "*" 20 | | binop2string DIV = "/" 21 | | binop2string MOD = "%" 22 | | binop2string AND = "&" 23 | | binop2string OR = "|" 24 | | binop2string LSHIFT = "<<" 25 | | binop2string RSHIFT = ">>" 26 | | binop2string ARSHIFT = "~>>" 27 | | binop2string XOR = "^" 28 | 29 | fun relop2string EQ = "==" 30 | | relop2string NE = "<>" 31 | | relop2string LT = "<" 32 | | relop2string GT = ">" 33 | | relop2string LE = "<=" 34 | | relop2string GE = ">=" 35 | | relop2string ULT = "!<" 36 | | relop2string UGT = "!>" 37 | | relop2string ULE = "!<=" 38 | | relop2string UGE = "!>=" 39 | 40 | fun notRel EQ = NE 41 | | notRel NE = EQ 42 | | notRel LT = GE 43 | | notRel GE = LT 44 | | notRel LE = GT 45 | | notRel GT = LE 46 | | notRel ULT = UGE 47 | | notRel UGE = ULT 48 | | notRel ULE = UGT 49 | | notRel UGT = ULE 50 | 51 | fun commute EQ = EQ 52 | | commute NE = NE 53 | | commute LT = GT 54 | | commute GT = LT 55 | | commute LE = GE 56 | | commute GE = LE 57 | | commute ULT = UGT 58 | | commute UGT = ULE 59 | | commute ULE = UGE 60 | | commute UGE = ULE 61 | end 62 | -------------------------------------------------------------------------------- /tvar.sml: -------------------------------------------------------------------------------- 1 | (* tvar.sml 2 | * 3 | * A "ref" type with an ordering relation (so that one can define 4 | * maps and sets of refs) for representing type- and rowtype variables. 5 | * 6 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 7 | *) 8 | structure TVar :> sig 9 | 10 | type 'a tvar 11 | type 'a rvar 12 | 13 | val tvar : 'a -> 'a tvar 14 | val rvar : 'a -> 'a rvar 15 | 16 | val tget : 'a tvar -> 'a 17 | val rget : 'a rvar -> 'a 18 | 19 | val tset : 'a tvar * 'a -> unit 20 | val rset : 'a rvar * 'a -> unit 21 | 22 | val teq : 'a tvar * 'a tvar -> bool 23 | val req : 'a rvar * 'a rvar -> bool 24 | 25 | val tcompare : 'a tvar * 'a tvar -> order (* not stable across link *) 26 | val rcompare : 'a rvar * 'a rvar -> order 27 | 28 | val reset : unit -> unit 29 | 30 | val link : 'a tvar * 'a tvar -> bool (* false if they were already equqal *) 31 | 32 | end = struct 33 | 34 | type 'a tvar = ('a * int) URef.uref 35 | type 'a rvar = 'a ref * int 36 | 37 | val tnext = ref 0 38 | val rnext = ref 0 39 | 40 | fun reset () = (tnext := 0; rnext := 0) 41 | 42 | fun tvar x = 43 | let val i = !tnext 44 | in tnext := i+1; 45 | URef.uRef (x, i) 46 | end 47 | fun rvar x = 48 | let val i = !rnext 49 | in rnext := i+1; 50 | (ref x, i) 51 | end 52 | 53 | fun tget (v: 'a tvar) = #1 (URef.!! v) 54 | fun rget (rv: 'a rvar) = !(#1 rv) 55 | 56 | fun tid (v: 'a tvar) = #2 (URef.!! v) 57 | 58 | fun tset (v, x) = URef.update (v, (x, tid v)) 59 | fun rset ((r, _), x) = r := x 60 | 61 | fun teq (v, w) = URef.equal (v, w) 62 | fun req ((_, i): 'a rvar, (_, j)) = i = j 63 | 64 | fun tcompare (v, w) = Int.compare (tid v, tid w) 65 | fun rcompare ((_, i), (_, j)) = Int.compare (i, j) 66 | 67 | fun link (v, w) = URef.link (v, w) 68 | end 69 | -------------------------------------------------------------------------------- /types.sml: -------------------------------------------------------------------------------- 1 | (* types.sml 2 | * 3 | * ML types of data structures representing MLPolyR types. 4 | * 5 | * Copyright (c) 2006 by Matthias Blume (blume@tti-c.org) 6 | *) 7 | structure Types = struct 8 | 9 | type region = Ast.region 10 | 11 | type label = RecordLabel.label 12 | type depth = int 13 | 14 | type exclusion = region RecordLabel.Map.map 15 | 16 | datatype tycon = 17 | INTtyc 18 | | BOOLtyc 19 | | STRINGtyc 20 | | FUNtyc 21 | | MATCHtyc 22 | | LISTtyc 23 | | RECORDtyc of Purity.purity 24 | | SUMtyc 25 | 26 | (* fields: *) 27 | 28 | type 'a field = label * ('a * region) 29 | 30 | (* types: *) 31 | 32 | datatype typ = 33 | VARty of tyvar 34 | | CONty of tycon * typ list * rtyp list * region 35 | 36 | and tyvarval = 37 | INST of typ 38 | | OPEN of depth * region 39 | 40 | and rtyp = 41 | VARrty of rtyvar 42 | | EMPTYrty of region 43 | | FIELDrty of typ field * rtyp 44 | 45 | and rtyvarval = 46 | RINST of rtyp 47 | | ROPEN of depth * rtyvarkind * region 48 | 49 | withtype tyvar = tyvarval TVar.tvar 50 | and rtyvar = rtyvarval TVar.rvar 51 | 52 | and rtyvarkind = exclusion 53 | 54 | (* type schemas: *) 55 | 56 | type tsvar = int (* bound type in type schemas *) 57 | type rtsvar = int (* bound row type variable in type schema *) 58 | 59 | datatype typs = 60 | PLAINtys of typ 61 | | CONtys of tycon * typs list * rtyps list * region 62 | | MUtys of tsvar * typs * region 63 | | REFtys of tsvar 64 | 65 | and rtyps = 66 | VARrtys of rtyvar 67 | | EMPTYrtys of region 68 | | FIELDrtys of typs field * rtyps 69 | | REFrtys of rtsvar 70 | 71 | type typschema = { targs: int, rargs: rtyvarkind list, body: typs } 72 | 73 | 74 | (* sets and maps of row variables: *) 75 | 76 | (* TSet and TMap do not work across TVar.link operations 77 | * on their keys! *) 78 | structure TSet = RedBlackSetFn (type ord_key = tyvar 79 | val compare = TVar.tcompare) 80 | structure TMap = RedBlackMapFn (type ord_key = tyvar 81 | val compare = TVar.tcompare) 82 | structure RTSet = RedBlackSetFn (type ord_key = rtyvar 83 | val compare = TVar.rcompare) 84 | structure RTMap = RedBlackMapFn (type ord_key = rtyvar 85 | val compare = TVar.rcompare) 86 | 87 | (* poly row info: *) 88 | 89 | type pri_rtyvarkind = RecordLabel.Set.set 90 | type pri = (rtyvar * pri_rtyvarkind) list (* polymorphic row info *) 91 | 92 | type prepolytype = typ * pri (* old row type vars *) 93 | 94 | (* utility functions: *) 95 | 96 | fun INTty r = CONty (INTtyc, [], [], r) 97 | fun BOOLty r = CONty (BOOLtyc, [], [], r) 98 | fun STRINGty r = CONty (STRINGtyc, [], [], r) 99 | fun FUNty (t1, t2, ert, r) = CONty (FUNtyc, [t1, t2], [ert], r) 100 | fun FUNtys (ts1, ts2, erts, r) = CONtys (FUNtyc, [ts1, ts2], [erts], r) 101 | fun MATCHty (rt, t, ert, r) = CONty (MATCHtyc, [t], [rt, ert], r) 102 | fun LISTty (t, r) = CONty (LISTtyc, [t], [], r) 103 | fun RECORDty (p, rt, r) = CONty (RECORDtyc p, [], [rt], r) 104 | fun SUMty (rt, r) = CONty (SUMtyc, [], [rt], r) 105 | fun UNITty r = RECORDty (Purity.Pure, EMPTYrty r, r) 106 | 107 | fun TUPLEty (tl, r) = 108 | RECORDty (Purity.Pure, 109 | #1 (foldl (fn ((t, fr), (rt, i)) => 110 | (FIELDrty ((RecordLabel.NUMlab i, (t, r)), 111 | rt), 112 | i+1)) 113 | (EMPTYrty r, 1) 114 | tl), 115 | r) 116 | 117 | fun sameTyc (t: tycon, t') = t = t' 118 | 119 | fun regionOf (VARty v) = 120 | (case TVar.tget v of 121 | INST t => regionOf t 122 | | OPEN (_, r) => r) 123 | | regionOf (CONty (_, _, _, r)) = r 124 | 125 | fun rregionOf (VARrty v) = 126 | (case TVar.rget v of 127 | RINST rt => rregionOf rt 128 | | ROPEN (_, _, r) => r) 129 | | rregionOf (EMPTYrty r) = r 130 | | rregionOf (FIELDrty ((_, (_, r)), _)) = r 131 | 132 | val unconstrained : rtyvarkind = RecordLabel.Map.empty 133 | end 134 | -------------------------------------------------------------------------------- /uncurry.sml: -------------------------------------------------------------------------------- 1 | (* uncurry.sml 2 | * 3 | * ... 4 | * 5 | * Copyright (c) 2005 Matthias Blume (blume@tti-c.org) 6 | *) 7 | 8 | (* 9 | 10 | FIX ([(f0, vl0, 11 | FIX ([(f1, vl1, 12 | FIX ([(f2, vl2, 13 | ... 14 | FIX ([(fk, vlk, 15 | e)], 16 | fk) ...)], 17 | f2))], 18 | f1)), 19 | ...], 20 | ...) 21 | 22 | => 23 | 24 | FIX ([(f, vl0 @ vl1 @ vl2 @ ... @ vlk, 25 | FIX ([header(1..k)], 26 | FIX ([header(2..k)], 27 | ... 28 | FIX ([header(k..k)], 29 | e) ...))), 30 | header(0..k), 31 | ...], 32 | ...) 33 | 34 | where 35 | 36 | header(i..k) = 37 | (fi, vli', 38 | FIX ([(f{i+1}', vl{i+1}', 39 | ... 40 | FIX ([(fk', vlk', 41 | f (vl0 @ ... @ vl{i-1} @ 42 | vli' @ vl{i+1}' @ ... @ vlk'))], 43 | fk') ...)], 44 | f{i+1}')) 45 | 46 | *) 47 | structure Uncurry : sig 48 | 49 | val transform : ANF.function -> ANF.function 50 | 51 | end = struct 52 | 53 | structure A = ANF 54 | 55 | (* We don't attempt to uncurry exception handlers. *) 56 | fun transform { f = (f, vl, e), inl, hdlr } = 57 | let fun function ({ f = (f0, vl0, e0), inl = inl0, hdlr = false }, fl) = 58 | let fun build (rl, (f0, vl0, inl0), e) = 59 | let val l = rev rl 60 | val f0' = LVar.clone f0 61 | val inl0' = inl0 andalso List.all #3 l 62 | val vl0_k = 63 | vl0 @ foldr (fn ((_, vl, _), avl) => vl @ avl) 64 | [] l 65 | fun header (pfx, (f, vl, inl), l) = 66 | let fun gen (pfx, []) = 67 | A.JUMP (Purity.Impure, 68 | (A.VAR f0', map A.VAR pfx)) 69 | | gen (pfx, (f, vl, inl) :: l) = 70 | let val f' = LVar.clone f 71 | val vl' = map LVar.clone vl 72 | val h = gen (pfx @ vl', l) 73 | in A.FIX ([{ f = (f', vl', h), 74 | inl = true, 75 | hdlr = false }], 76 | A.VALUES [A.VAR f']) 77 | end 78 | val vl' = map LVar.clone vl 79 | in { f = (f, vl', gen (pfx @ vl', l)), 80 | inl = true, hdlr = false } 81 | end 82 | fun withHeaders (pfx, []) = e 83 | | withHeaders (pfx, h :: t) = 84 | A.FIX ([header (pfx, h, t)], 85 | withHeaders (pfx @ #2 h, t)) 86 | val fu0' = { f = (f0', vl0_k, withHeaders (vl0, l)), 87 | inl = inl0', hdlr = false } 88 | val h0 = header ([], (f0, vl0, inl0), l) 89 | in fu0' :: h0 :: fl 90 | end 91 | fun dump ([], (f0, vl0, inl0), e) = 92 | { f = (f0, vl0, e), inl = inl0, hdlr = false } :: fl 93 | | dump ((f, vl, inl) :: rl, i0, e) = 94 | dump (rl, i0, 95 | A.FIX ([{ f = (f, vl, e), 96 | inl = inl, 97 | hdlr = false }], 98 | A.VALUES [A.VAR f])) 99 | fun uncurry (rl, i0, 100 | e as A.FIX ([{ f = (f, vl, b), inl, hdlr }], 101 | A.VALUES [A.VAR v])) = 102 | if not hdlr andalso f = v then 103 | uncurry ((f, vl, inl) :: rl, i0, b) 104 | else build (rl, i0, exp e) 105 | | uncurry (rl, i0, e as (A.VALUES _ | A.JUMP _)) = 106 | dump (rl, i0, e) 107 | | uncurry (rl, i0, e) = 108 | build (rl, i0, exp e) 109 | 110 | in case e0 of 111 | A.FIX ([{ f = (f1, vl1, e1), inl = inl1, hdlr = false }], 112 | A.VALUES [A.VAR v]) => 113 | if f1 = v then 114 | uncurry ([(f1, vl1, inl1)], (f0, vl0, inl0), e1) 115 | else { f = (f0, vl0, exp e0), 116 | inl = inl0, hdlr = false } :: fl 117 | | _ => { f = (f0, vl0, exp e0), 118 | inl = inl0, hdlr = false } :: fl 119 | end 120 | | function (f, fl) = f :: fl 121 | 122 | and exp (e as A.VALUES _) = e 123 | | exp (A.BIND (v, x, e)) = A.BIND (v, x, exp e) 124 | | exp (A.CALL (p, vl, xxl, e)) = A.CALL (p, vl, xxl, exp e) 125 | | exp (A.FIX (fl, e)) = A.FIX (foldr function [] fl, exp e) 126 | | exp (A.ARITH (a, x, y, v, e)) = A.ARITH (a, x, y, v, exp e) 127 | | exp (A.RECORD (p, x, sl, v, e)) = A.RECORD (p, x, sl, v, exp e) 128 | | exp (A.SELECT (x, y, p, v, e)) = A.SELECT (x, y, p, v, exp e) 129 | | exp (A.UPDATE (x, y, z, e)) = A.UPDATE (x, y, z, exp e) 130 | | exp (A.CMP (c, x, y, et, ef)) = A.CMP (c, x, y, exp et, exp ef) 131 | | exp (A.GETSP (v, e)) = A.GETSP (v, exp e) 132 | | exp (A.SETSP (x, e)) = A.SETSP (x, exp e) 133 | | exp (A.MAYJUMP (v, e)) = A.MAYJUMP (v, exp e) 134 | | exp (e as A.JUMP _) = e 135 | in { f = (f, vl, exp e), inl = inl, hdlr = hdlr } 136 | end 137 | end 138 | -------------------------------------------------------------------------------- /util/serv.sml: -------------------------------------------------------------------------------- 1 | fun serv n = 2 | CM.Server.start { name = n, pref = 0, pathtrans = NONE, 3 | cmd = ("/Users/blume/bin/sml", ["@CMslave"]) }; 4 | 5 | -------------------------------------------------------------------------------- /value-numbering.sml: -------------------------------------------------------------------------------- 1 | (* value-numbering.sml 2 | * 3 | * Simple Common Subexpression Elimination (CSE) by Value Numbering 4 | * within basic blocks. 5 | * 6 | * Copyright (c) 2005 by Matthias Blume (blume@tti-c.org) 7 | *) 8 | structure ValueNumbering : sig 9 | 10 | val block_cse : Closed.block -> Closed.block 11 | 12 | val cluster_cse : Closed.cluster -> Closed.cluster 13 | 14 | end = struct 15 | 16 | structure C = Closed 17 | 18 | val callidx = 0 19 | val recordidx = 1 20 | val selectidx = 2 21 | fun arithidx Oper.PLUS = 3 22 | | arithidx Oper.MINUS = 4 23 | | arithidx Oper.TIMES = 5 24 | | arithidx Oper.DIV = 6 25 | | arithidx Oper.MOD = 7 26 | 27 | fun valuecompare (C.INT i, C.INT i') = LiteralData.compare (i, i') 28 | | valuecompare (C.INT _, _) = GREATER 29 | | valuecompare (_, C.INT _) = LESS 30 | | valuecompare (C.LABEL l, C.LABEL l') = Label.compare (l, l') 31 | | valuecompare (C.LABEL _, _) = GREATER 32 | | valuecompare (_, C.LABEL _) = LESS 33 | | valuecompare (C.VAR v, C.VAR v') = LVar.compare (v, v') 34 | 35 | and valuelistcompare (l, l') = List.collate valuecompare (l, l') 36 | 37 | and slicecompare (C.SGT x, C.SGT x') = valuecompare (x, x') 38 | | slicecompare (C.SGT _, C.SEQ _) = GREATER 39 | | slicecompare (C.SEQ _, C.SGT _) = LESS 40 | | slicecompare (C.SEQ s, C.SEQ s') = 41 | valuelistcompare ([#base s, #start s, #stop s], 42 | [#base s', #start s', #stop s']) 43 | 44 | and slicelistcompare (l, l') = List.collate slicecompare (l, l') 45 | 46 | fun compare ((i, sl), (i', sl')) = 47 | case Int.compare (i, i') of 48 | EQUAL => slicelistcompare (sl, sl') 49 | | unequal => unequal 50 | 51 | structure M = RedBlackMapFn (type ord_key = int * C.slice list 52 | val compare = compare) 53 | structure EM = LVar.Map 54 | 55 | fun repr (v, eq) = getOpt (EM.find (eq, v), C.VAR v) 56 | 57 | fun block_cse (l, vl, e) = 58 | let fun value (C.VAR v, eq) = repr (v, eq) 59 | | value (x as (C.INT _ | C.LABEL _), _) = x 60 | 61 | fun valuelist ([], _) = [] 62 | | valuelist (x :: xl, eq) = value (x, eq) :: valuelist (xl, eq) 63 | 64 | fun slice (C.SGT x, eq) = C.SGT (value (x, eq)) 65 | | slice (C.SEQ { base, start, stop }, eq) = 66 | C.SEQ { base = value (base, eq), 67 | start = value (start, eq), 68 | stop = value (stop, eq) } 69 | 70 | fun slicelist ([], _) = [] 71 | | slicelist (s :: sl, eq) = slice (s, eq) :: slicelist (sl, eq) 72 | 73 | fun jtarget ((x, xl), eq) = (value (x, eq), valuelist (xl, eq)) 74 | 75 | fun sgtkey (idx, xl) = (idx, map C.SGT xl) 76 | fun callkey (x, xl) = sgtkey (callidx, x :: xl) 77 | fun recordkey (x, sl) = (recordidx, C.SGT x :: sl) 78 | fun selectkey (x, y) = sgtkey (selectidx, [x, y]) 79 | 80 | fun arithkey (aop, x, y) = 81 | let val idx = arithidx aop 82 | in if Oper.commutative aop then 83 | case valuecompare (x, y) of 84 | GREATER => sgtkey (idx, [y, x]) 85 | | _ => sgtkey (idx, [x, y]) 86 | else sgtkey (idx, [x, y]) 87 | end 88 | 89 | fun memo (k, v, e, m, eq, c) = 90 | case M.find (m, k) of 91 | SOME y => exp (e, m, EM.insert (eq, v, y)) 92 | | NONE => c (exp (e, M.insert (m, k, C.VAR v), eq)) 93 | 94 | and exp (C.VALUES xl, _, eq) = C.VALUES (valuelist (xl, eq)) 95 | | exp (C.BIND (v, x, e), m, eq) = 96 | exp (e, m, EM.insert (eq, v, value (x, eq))) 97 | | exp (C.CALL (Purity.Pure, [v], jt, e), m, eq) = 98 | let val (x', xl') = jtarget (jt, eq) 99 | in memo (callkey (x', xl'), v, e, m, eq, 100 | fn b => C.CALL (Purity.Pure, [v], (x', xl'), b)) 101 | end 102 | | exp (C.CALL (p, vl, jt, e), m, eq) = 103 | C.CALL (p, vl, jtarget (jt, eq), exp (e, m, eq)) 104 | | exp (C.ARITH (aop, x, y, v, e), m, eq) = 105 | let val (x', y') = (value (x, eq), value (y, eq)) 106 | in memo (arithkey (aop, x', y'), v, e, m, eq, 107 | fn b => C.ARITH (aop, x', y', v, b)) 108 | end 109 | | exp (C.RECORD (Purity.Impure, x, sl, v, e), m, eq) = 110 | C.RECORD (Purity.Impure, 111 | value (x, eq), slicelist (sl, eq), 112 | v, exp (e, m, eq)) 113 | | exp (C.RECORD (Purity.Pure, x, sl, v, e), m, eq) = 114 | let val x' = value (x, eq) 115 | val sl' = slicelist (sl, eq) 116 | in memo (recordkey (x', sl'), v, e, m, eq, 117 | fn b => C.RECORD (Purity.Pure, x', sl', v, b)) 118 | end 119 | | exp (C.SELECT (x, y, Purity.Impure, v, e), m, eq) = 120 | C.SELECT (value (x, eq), value (y, eq), Purity.Impure, v, 121 | exp (e, m, eq)) 122 | | exp (C.SELECT (x, y, Purity.Pure, v, e), m, eq) = 123 | let val (x', y') = (value (x, eq), value (y, eq)) 124 | in memo (selectkey (x', y'), v, e, m, eq, 125 | fn b => C.SELECT (x', y', Purity.Pure, v, b)) 126 | end 127 | | exp (C.UPDATE (x, y, z, e), m, eq) = 128 | C.UPDATE (value (x, eq), value (y, eq), value (z, eq), 129 | exp (e, m, eq)) 130 | | exp (C.CMP (cop, x, y, (l1, xl1), (l2, xl2)), m, eq) = 131 | C.CMP (cop, value (x, eq), value (y, eq), 132 | (l1, valuelist (xl1, eq)), (l2, valuelist (xl2, eq))) 133 | | exp (C.JUMP jt, _, eq) = C.JUMP (jtarget (jt, eq)) 134 | | exp (C.GETSP (v, e), m, eq) = 135 | C.GETSP (v, exp (e, m, eq)) 136 | | exp (C.SETSP (x, e), m, eq) = 137 | C.SETSP (value (x, eq), exp (e, m, eq)) 138 | | exp (C.MAYJUMP (l, e), m, eq) = 139 | C.MAYJUMP (l, exp (e, m, eq)) 140 | in (l, vl, exp (e, M.empty, EM.empty)) 141 | end 142 | 143 | fun eblock_cse (l, vl, e, eh) = 144 | let val (l', vl', e') = block_cse (l, vl, e) 145 | in (l', vl', e', eh) 146 | end 147 | 148 | fun cluster_cse { entryblocks, labelblocks } = 149 | { entryblocks = map eblock_cse entryblocks, 150 | labelblocks = map block_cse labelblocks } 151 | end 152 | --------------------------------------------------------------------------------