├── .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 |
--------------------------------------------------------------------------------