From 278ee46f0fa93a3db4ebdc6878fcd9b1d990094a Mon Sep 17 00:00:00 2001 From: Rose Hogenson Date: Sun, 7 Apr 2024 09:11:28 -0700 Subject: Add tests and fix variables. --- codegen.sml | 10 +++++----- cps.sml | 13 +++++++------ elab.sml | 21 +++++++++++++-------- parser.sml | 7 ++++++- run_tests.fish | 18 ++++++++++++++++++ syntax.sml | 14 ++++++++------ tests/01-simple.sml | 1 + tests/02-lambda.sml | 1 + tests/03-arg.sml | 1 + tests/04-val.sml | 2 ++ tests/lambda | 1 - tests/simple | 1 - 12 files changed, 62 insertions(+), 28 deletions(-) create mode 100644 run_tests.fish create mode 100644 tests/01-simple.sml create mode 100644 tests/02-lambda.sml create mode 100644 tests/03-arg.sml create mode 100644 tests/04-val.sml delete mode 100644 tests/lambda delete mode 100644 tests/simple diff --git a/codegen.sml b/codegen.sml index 84f3ad5..befedac 100644 --- a/codegen.sml +++ b/codegen.sml @@ -51,9 +51,9 @@ struct shuffle' inputMap outputMap @ constants end - fun buildVarMap (expr : Syntax.cexp) : Syntax.var VarMap.map = + fun buildVarMap (first : int) (expr : Syntax.cexp) : Syntax.var VarMap.map = let - val next = ref 0 + val next = ref first fun insert v m = let val this = !next in @@ -78,7 +78,7 @@ struct (ListPair.zip (List.tabulate (length args, fn x => x + 1), args)) - val bodyVars = buildVarMap body + val bodyVars = buildVarMap (length args + 1) body in VarMap.union (VarMap.union acc argsVars) bodyVars end) VarMap.empty @@ -106,7 +106,7 @@ struct fun toASM (expr : Syntax.cexp) : Syntax.opcode list = let - val varMap = buildVarMap expr + val varMap = buildVarMap 0 expr fun translate v = case VarMap.lookup v varMap of NONE => raise Fail ("unable to translate var " ^ Int.toString v) @@ -144,7 +144,7 @@ struct in bodyASM @ funcsASM end - | Syntax.CPrimop (Syntax.PExit, [arg], _, _)=> [Syntax.OExit arg] + | Syntax.CPrimop (Syntax.PExit, [arg], _, _)=> [Syntax.OExit (translateVal arg)] | _ => raise Fail ("malformed CPS:\n" ^ Syntax.cexpToString expr) in go expr end diff --git a/cps.sml b/cps.sml index 56780a9..adb29c0 100644 --- a/cps.sml +++ b/cps.sml @@ -61,17 +61,18 @@ struct fun hoist (expr : Syntax.cexp) : Syntax.cexp = let - fun funs (Syntax.CRecord (_, _, k)) acc = funs k acc - | funs (Syntax.CSelect (_, _, _, k)) acc = funs k acc - | funs (Syntax.CApp _) acc = acc - | funs (Syntax.CFix (fs, body)) acc = funs body (fs @ acc) - | funs (Syntax.CPrimop (_, _, _, ks)) acc = foldl (fn (x, acc) => funs x acc) acc ks - fun exprs (Syntax.CRecord (args, res, k)) = Syntax.CRecord (args, res, exprs k) | exprs (Syntax.CSelect (i, arg, res, k)) = Syntax.CSelect (i, arg, res, exprs k) | exprs (expr as Syntax.CApp _) = expr | exprs (Syntax.CFix (_, body)) = exprs body | exprs (Syntax.CPrimop (p, args, res, ks)) = Syntax.CPrimop (p, args, res, (map exprs ks)) + + fun funs (Syntax.CRecord (_, _, k)) acc = funs k acc + | funs (Syntax.CSelect (_, _, _, k)) acc = funs k acc + | funs (Syntax.CApp _) acc = acc + | funs (Syntax.CFix (fs, body)) acc = + funs body (foldl (fn ((fName, fVars, fBody), acc) => (fName, fVars, exprs fBody) :: funs fBody acc) acc fs) + | funs (Syntax.CPrimop (_, _, _, ks)) acc = foldl (fn (x, acc) => funs x acc) acc ks val entryPoint = Gensym.new () in Syntax.CFix ((entryPoint, [], exprs expr) :: funs expr [], Syntax.CApp (Syntax.VLabel entryPoint, [])) diff --git a/elab.sml b/elab.sml index 032d1d7..52d0089 100644 --- a/elab.sml +++ b/elab.sml @@ -27,21 +27,26 @@ struct | Syntax.ETyped (e, _) => elab env e | Syntax.EAndAlso (_, _) => raise Fail "unimplemented" | Syntax.EOrElse (_, _) => raise Fail "unimplemented" - | Syntax.ELet (decls, body) => - foldr - (fn (Syntax.DVal v, acc) => - Syntax.LApp (Syntax.LFn (Gensym.new (), acc), elab env v)) - (elab env body) - decls - | Syntax.ELambda (var, body) => + | Syntax.ELet ([], body) => elab env body + | Syntax.ELet (Syntax.DVal (pat, v) :: decls, body) => + elab env (Syntax.ECase (v, [(pat, Syntax.ELet (decls, body))])) + | Syntax.ELambda (pat, body) => let val v = Gensym.new () val env' = - case var of + case pat of Syntax.PWild => env | Syntax.PVar name => StringMap.insert name v env in Syntax.LFn (v, elab env' body) end + | Syntax.ECase (expr, []) => raise Fail "nonexhaustive match" + | Syntax.ECase (expr, (pat, body) :: rest) => + if rest <> [] then raise Fail "redundant match" else + let val v = Gensym.new () in + case pat of + Syntax.PWild => Syntax.LApp (Syntax.LFn (v, elab env body), elab env expr) + | Syntax.PVar name => Syntax.LApp (Syntax.LFn (v, elab (StringMap.insert name v env) body), elab env expr) + end fun elaborate (p : Syntax.expr) : Syntax.lexp = elab StringMap.empty p end diff --git a/parser.sml b/parser.sml index af3dfd7..6efc4aa 100644 --- a/parser.sml +++ b/parser.sml @@ -447,7 +447,12 @@ struct const (Syntax.ELambda (p, e))))) <|> raiseExpr) st and expr : Syntax.expr parser = fn st => fnExpr st - and dec : Syntax.dec parser = fn st => (reserved "val" >> reserved "_" >> reserved "=" >> Syntax.DVal <$> expr) st + and dec : Syntax.dec parser = fn st => + (reserved "val" >> + bind pat (fn p => + reserved "=" >> + bind expr (fn e => + const (Syntax.DVal (p, e))))) st val program : Syntax.expr parser = (fn decs => Syntax.ELet (decs, Syntax.EInt 0)) <$> many dec fun parse (f : string) : (string, Syntax.expr) Result.either = runParser program f diff --git a/run_tests.fish b/run_tests.fish new file mode 100644 index 0000000..f91b8ae --- /dev/null +++ b/run_tests.fish @@ -0,0 +1,18 @@ +#!/usr/bin/env fish + +set d (realpath (status dirname)) + +cd $d/bytecode +cargo build + +cd $d + +for f in $d/tests/*.sml + $d/bytecode/target/debug/bytecode (sml $d/main.sml -o /dev/stderr $f >/dev/null 2>| psub) + set -l got $status + if test $got -eq 42 + echo (basename -s.sml $f): PASS + else + echo (basename -s.sml $f): FAIL "(status $got)" + end +end diff --git a/syntax.sml b/syntax.sml index 2a7ee9a..3e70ba1 100644 --- a/syntax.sml +++ b/syntax.sml @@ -24,8 +24,9 @@ struct | EOrElse of expr * expr | ELet of dec list * expr | ELambda of pat * expr + | ECase of expr * (pat * expr) list - and dec = DVal of expr + and dec = DVal of pat * expr (* Lambda language *) type var = int @@ -106,11 +107,12 @@ struct | EOrElse (a, b) => "EOrElse (" ^ self a ^ ", " ^ self b ^ ")" | ELet (decs, e) => "ELet (" ^ multilineListToString decToStringI indent decs ^ ", " ^ self e ^ ")" | ELambda (pat, e) => "ELambda (" ^ patToString pat ^ ", " ^ exprToStringI indent e ^ ")" + | ECase (e, branches) => "ECase (" ^ self e ^ ", " ^ multilineListToString (fn indent => fn (pat, body) => "(" ^ patToString pat ^ ", " ^ exprToStringI indent body ^ ")") indent branches ^ ")" end and decToStringI (indent : string) (x : dec) : string = case x of - DVal e => "DVal (" ^ exprToStringI indent e ^ ")" + DVal (p, e) => "DVal (" ^ patToString p ^ ", " ^ exprToStringI indent e ^ ")" val exprToString : expr -> string = exprToStringI "" @@ -154,11 +156,11 @@ struct fun opcodeToString (oper : opcode) : string = case oper of - OAlloc (r, s) => "OAlloc (" ^ Int.toString r ^ ", " ^ valueToString s ^ ")" + OAlloc (r, s) => "Var " ^ Int.toString r ^ " = OAlloc(" ^ valueToString s ^ ")" | OCall => "OCall" - | OPoke (i, p, v) => "OPoke (" ^ Int.toString i ^ ", " ^ Int.toString p ^ ", " ^ valueToString v ^ ")" - | OPeek (r, i, p) => "OPeek (" ^ Int.toString r ^ ", " ^ Int.toString i ^ ", " ^ valueToString p ^ ")" - | OShuf (d, s) => "OShuf (" ^ Int.toString d ^ ", " ^ valueToString s ^ ")" + | OPoke (i, p, v) => "Var " ^ Int.toString p ^ "[" ^ Int.toString i ^ "] = " ^ valueToString v + | OPeek (r, i, p) => "Var " ^ Int.toString r ^ " = " ^ valueToString p ^ "[" ^ Int.toString i ^ "]" + | OShuf (d, s) => "Var " ^ Int.toString d ^ " = " ^ valueToString s | OExit v => "OExit " ^ valueToString v | OLabel l => "OLabel " ^ Int.toString l end diff --git a/tests/01-simple.sml b/tests/01-simple.sml new file mode 100644 index 0000000..3e87f14 --- /dev/null +++ b/tests/01-simple.sml @@ -0,0 +1 @@ +val _ = __builtin "exit" 42 diff --git a/tests/02-lambda.sml b/tests/02-lambda.sml new file mode 100644 index 0000000..41470a2 --- /dev/null +++ b/tests/02-lambda.sml @@ -0,0 +1 @@ +val _ = (fn _ => __builtin "exit" 42) () diff --git a/tests/03-arg.sml b/tests/03-arg.sml new file mode 100644 index 0000000..8d10139 --- /dev/null +++ b/tests/03-arg.sml @@ -0,0 +1 @@ +val _ = (fn x => __builtin "exit" x) 42 diff --git a/tests/04-val.sml b/tests/04-val.sml new file mode 100644 index 0000000..20d07b4 --- /dev/null +++ b/tests/04-val.sml @@ -0,0 +1,2 @@ +val x = 42 +val _ = __builtin "exit" x diff --git a/tests/lambda b/tests/lambda deleted file mode 100644 index 45a6137..0000000 --- a/tests/lambda +++ /dev/null @@ -1 +0,0 @@ -val _ = (fn _ => __builtin "exit" 5) () diff --git a/tests/simple b/tests/simple deleted file mode 100644 index d757a7f..0000000 --- a/tests/simple +++ /dev/null @@ -1 +0,0 @@ -val _ = __builtin "exit" 5 -- cgit v1.3.1