From 5582235bd300f8de997192f9109d596d12df4bbe Mon Sep 17 00:00:00 2001 From: Rose Hogenson Date: Fri, 16 May 2025 16:54:17 -0700 Subject: Fix spelling of file names --- Buffer.sml | 50 +++++ CPS.sml | 271 +++++++++++++++++++++++ CodeGen.sml | 181 ++++++++++++++++ Compiler.sml | 40 ++++ Elab.sml | 419 +++++++++++++++++++++++++++++++++++ GenSym.sml | 5 + Linker.sml | 149 +++++++++++++ Map.sml | 186 ++++++++++++++++ Opts.sml | 81 +++++++ Parser.sml | 672 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Result.sml | 4 + Sort.sml | 24 +++ Syntax.sml | 231 ++++++++++++++++++++ buffer.sml | 50 ----- codegen.sml | 181 ---------------- compiler.sml | 40 ---- cps.sml | 271 ----------------------- elab.sml | 419 ----------------------------------- gensym.sml | 5 - linker.sml | 149 ------------- main.sml | 27 ++- map.sml | 186 ---------------- opts.sml | 81 ------- parser.sml | 672 --------------------------------------------------------- program.cm | 24 +-- result.sml | 4 - run-tests.fish | 24 +++ run_tests.fish | 24 --- sort.sml | 24 --- syntax.sml | 231 -------------------- 30 files changed, 2362 insertions(+), 2363 deletions(-) create mode 100644 Buffer.sml create mode 100644 CPS.sml create mode 100644 CodeGen.sml create mode 100644 Compiler.sml create mode 100644 Elab.sml create mode 100644 GenSym.sml create mode 100644 Linker.sml create mode 100644 Map.sml create mode 100644 Opts.sml create mode 100644 Parser.sml create mode 100644 Result.sml create mode 100644 Sort.sml create mode 100644 Syntax.sml delete mode 100644 buffer.sml delete mode 100644 codegen.sml delete mode 100644 compiler.sml delete mode 100644 cps.sml delete mode 100644 elab.sml delete mode 100644 gensym.sml delete mode 100644 linker.sml delete mode 100644 map.sml delete mode 100644 opts.sml delete mode 100644 parser.sml delete mode 100644 result.sml create mode 100644 run-tests.fish delete mode 100644 run_tests.fish delete mode 100644 sort.sml delete mode 100644 syntax.sml diff --git a/Buffer.sml b/Buffer.sml new file mode 100644 index 0000000..054f29c --- /dev/null +++ b/Buffer.sml @@ -0,0 +1,50 @@ +structure Buffer = +struct + fun append (a : Word8ArraySlice.slice) (b : Word8ArraySlice.slice) : Word8ArraySlice.slice = + let + val bLen = Word8ArraySlice.length b + val (base, i, aLen) = Word8ArraySlice.base a + val baseLen = Word8Array.length base + in + if i + aLen + bLen <= baseLen + then + (Word8ArraySlice.copy { src = b, dst = base, di = i + aLen } ; + Word8ArraySlice.slice (base, i, SOME (aLen + bLen))) + else + let val newBuf = Word8Array.array (baseLen * 2 + bLen, Word8.fromInt 0) + in + Word8ArraySlice.copy { src = a, dst = newBuf, di = 0 } ; + Word8ArraySlice.copy { src = b, dst = newBuf, di = aLen } ; + Word8ArraySlice.slice (newBuf, 0, SOME (aLen + bLen)) + end + end + + fun buf () : BinIO.outstream * Word8ArraySlice.slice ref = + let val buffer = ref (Word8ArraySlice.full (Word8Array.array (0, Word8.fromInt 0))) + in + (BinIO.mkOutstream + (BinIO.StreamIO.mkOutstream + (BinPrimIO.WR + { name = "buffer" + , chunkSize = 1 + , writeVec = NONE + , writeArr = + SOME + (fn a => + (buffer := append (!buffer) a ; + Word8ArraySlice.length a)) + , writeVecNB = NONE + , writeArrNB = NONE + , block = NONE + , canOutput = NONE + , getPos = NONE + , setPos = NONE + , endPos = NONE + , verifyPos = NONE + , close = fn () => () + , ioDesc = NONE + }, + IO.NO_BUF)), + buffer) + end +end diff --git a/CPS.sml b/CPS.sml new file mode 100644 index 0000000..13dbbe8 --- /dev/null +++ b/CPS.sml @@ -0,0 +1,271 @@ +structure CPS = +struct + fun toCPS (e : Syntax.lexp) (cont : Syntax.value -> Syntax.cexp) : Syntax.cexp = + case e of + Syntax.LVar v => cont (Syntax.VVar v) + | Syntax.LFn (v, expr) => + let + val fnName = GenSym.new () + val k = GenSym.new () + in + Syntax.CFix + ([(fnName, [v, k], toCPS expr (fn ret => Syntax.CApp (Syntax.VVar k, [ret])))], + cont (Syntax.VVar fnName)) + end + | Syntax.LFix (decls, body) => + Syntax.CFix + ( map + (fn (name, arg, expr) => + let val w = GenSym.new () + in + ( name + , [arg, w] + , toCPS expr (fn z => Syntax.CApp (Syntax.VVar w, [z])) + ) + end) + decls + , toCPS body cont + ) + | Syntax.LApp (Syntax.LPrim primop, Syntax.LRecord args) => + let + val temp = GenSym.new () + fun go [] acc = Syntax.CPrimop (primop, rev acc, [temp], [cont (Syntax.VVar temp)]) + | go (arg :: args) acc = toCPS arg (fn arg' => go args (arg' :: acc)) + in go args [] + end + | Syntax.LApp (Syntax.LPrim primop, arg) => toCPS (Syntax.LApp (Syntax.LPrim primop, Syntax.LRecord [arg])) cont + | Syntax.LApp (f, x) => + let + val addr = GenSym.new () + val arg = GenSym.new () + in Syntax.CFix + ([(addr, [arg], cont (Syntax.VVar arg))], + toCPS f (fn f' => + toCPS x (fn x' => + Syntax.CApp (f', [x', Syntax.VVar addr])))) + end + | Syntax.LInt i => cont (Syntax.VInt i) + | Syntax.LString s => + let val temp = GenSym.new () + in + Syntax.CRecord + ( [(map (fn c => (Syntax.VInt (Char.ord c), [])) (String.explode s), temp)] + , cont (Syntax.VVar temp) + ) + end + | Syntax.LRecord [] => cont (Syntax.VInt 0) + | Syntax.LSelect (i, expr) => + let val temp = GenSym.new () + in toCPS expr (fn x => Syntax.CSelect (i, x, temp, cont (Syntax.VVar temp))) + end + | Syntax.LRecord exprs => + let + fun go [] vars = + let val temp = GenSym.new () + in Syntax.CRecord ([(map (fn v => (v, [])) (rev vars), temp)], cont (Syntax.VVar temp)) + end + | go (expr :: exprs) vars = + toCPS expr (fn v => go exprs (v :: vars)) + in go exprs [] + end + | Syntax.LSwitch (expr, arms, otherwise) => + let + val sortedArms = Sort.sort (fn ((x, _), (y, _)) => Int.compare (x, y)) arms + val contAddr = GenSym.new () + val otherwiseAddr = GenSym.new () + val arg = GenSym.new () + fun go _ [] cont = Syntax.CApp (Syntax.VVar otherwiseAddr, []) + | go v [(x, arm)] cont = + (case otherwise of + NONE => toCPS arm cont + | SOME _ => + let val b = GenSym.new () + in + Syntax.CPrimop + ( Syntax.PEq + , [v, Syntax.VInt x] + , [b] + , [ Syntax.CPrimop + ( Syntax.PIf + , [Syntax.VVar b] + , [] + , [toCPS arm cont, Syntax.CApp (Syntax.VVar otherwiseAddr, [])] + ) + ] + ) + end) + | go v arms cont = + let + val b = GenSym.new () + val h = length arms div 2 + val half1 = List.take (arms, h) + val half2 = List.drop (arms, h) + val (x, _) = hd half2 + in + Syntax.CPrimop + ( Syntax.PLess + , [v, Syntax.VInt x] + , [b] + , [ Syntax.CPrimop + ( Syntax.PIf + , [Syntax.VVar b] + , [] + , [go v half1 cont, go v half2 cont] + ) + ] + ) + end + fun contFunc x = Syntax.CApp (Syntax.VVar contAddr, [x]) + val fixFuncs = [(contAddr, [arg], cont (Syntax.VVar arg))] + val fixFuncs = + case otherwise of + NONE => fixFuncs + | SOME otherwise => (otherwiseAddr, [], toCPS otherwise contFunc) :: fixFuncs + in + Syntax.CFix + ( fixFuncs + , toCPS expr (fn v => go v sortedArms contFunc) + ) + end + | _ => raise Fail ("malformed expression " ^ Syntax.lexpToString e) + + fun hoist (expr : Syntax.cexp) : Syntax.cexp = + let + fun exprs (Syntax.CRecord (records, k)) = Syntax.CRecord (records, 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, [])) + end + + structure VarMap = Map (type k = Syntax.var + val cmp = Int.compare) + + fun varSet (l : Syntax.var list) : unit VarMap.map = VarMap.fromList (map (fn x => (x, ())) l) + + fun freeVars (expr : Syntax.cexp) : unit VarMap.map = + case expr of + Syntax.CRecord (records, k) => + let + val kFreeVars = freeVars k + val argFreeVars = + foldl + (fn ((args, _), acc) => + VarMap.union acc (varSet (List.mapPartial (fn (Syntax.VVar v, _) => SOME v | _ => NONE) args))) + VarMap.empty + records + val results = + foldl + (fn ((_, res), acc) => + VarMap.insert res () acc) + VarMap.empty + records + in + VarMap.difference (VarMap.union kFreeVars argFreeVars) results + end + | Syntax.CSelect (_, arg, res, k) => + let + val argFreeVars = + case arg of + Syntax.VVar v => varSet [v] + | _ => VarMap.empty + val kFreeVars = VarMap.delete res (freeVars k) + in + VarMap.union argFreeVars kFreeVars + end + | Syntax.CApp (func, args) => + let + val funcFreeVars = + case func of + Syntax.VVar v => varSet [v] + | _ => VarMap.empty + val argFreeVars = varSet (List.mapPartial (fn Syntax.VVar v => SOME v | _ => NONE) args) + in + VarMap.union funcFreeVars argFreeVars + end + | Syntax.CFix (funs, body) => + let + val names = varSet (map (fn (name, _, _) => name) funs) + val funsFreeVars = map (fn (name, args, fixBody) => VarMap.difference (freeVars fixBody) (varSet args)) funs + val bodyFreeVars = freeVars body + in + foldl (fn (x, acc) => VarMap.union acc (VarMap.difference x names)) VarMap.empty (bodyFreeVars :: funsFreeVars) + end + | Syntax.CPrimop (_, args, res, ks) => + let + val argFreeVars = varSet (List.mapPartial (fn Syntax.VVar v => SOME v | _ => NONE) args) + val boundVars = varSet res + val kFreeVars = foldl (fn (x, acc) => VarMap.union acc x) VarMap.empty (map (fn k => VarMap.difference (freeVars k) boundVars) ks) + in + VarMap.union argFreeVars kFreeVars + end + + fun freeVarsClosure (name, args, body) = map (fn (x, _) => x) (VarMap.toList (VarMap.difference (freeVars body) (varSet args))) + + fun enumerate l = ListPair.zip (List.tabulate (length l, (fn x => x)), l) + + fun convertExpr varMap expr = + let + fun translate var = getOpt (VarMap.lookup var varMap, var) + fun translateValue (Syntax.VVar v) = Syntax.VVar (translate v) + | translateValue v = v + in + case expr of + Syntax.CRecord (records, k) => + Syntax.CRecord (map (fn (args, res) => (map (fn (v, p) => (translateValue v, p)) args, res)) records, convertExpr varMap k) + | Syntax.CSelect (i, arg, res, k) => + Syntax.CSelect (i, translateValue arg, res, convertExpr varMap k) + | Syntax.CApp (func, args) => + let + val temp = GenSym.new () + val f = translateValue func + in Syntax.CSelect (0, f, temp, + Syntax.CApp (Syntax.VVar temp, f :: map translateValue args)) + end + | Syntax.CFix (funcs, body) => + let + val convertedFuncs = + map + (fn this as (name, args, body) => + let + val funcFreeVars = freeVarsClosure this + val varMap' = VarMap.union varMap (VarMap.fromList (map (fn v => (v, GenSym.new ())) funcFreeVars)) + val closure = GenSym.new () + val newBody = + foldl + (fn ((i, x), acc) => Syntax.CSelect (i + 1, Syntax.VVar closure, valOf (VarMap.lookup x varMap'), acc)) + (convertExpr varMap' body) + (enumerate funcFreeVars) + in + (GenSym.new (), closure :: args, newBody) + end) + funcs + val newBody = + Syntax.CRecord + ( map + (fn (old as (oldName, args, body), (newName, _, _)) => + let val funcFreeVars = freeVarsClosure old + in ((Syntax.VLabel newName, []) :: map (fn v => (Syntax.VVar (translate v), [])) funcFreeVars, oldName) + end) + (ListPair.zip (funcs, convertedFuncs)) + , convertExpr varMap body + ) + in + Syntax.CFix (convertedFuncs, newBody) + end + | Syntax.CPrimop (p, args, res, ks) => + Syntax.CPrimop (p, map translateValue args, res, map (convertExpr varMap) ks) + end + + fun convertClosures (expr : Syntax.cexp) : Syntax.cexp = hoist (convertExpr VarMap.empty expr) +end diff --git a/CodeGen.sml b/CodeGen.sml new file mode 100644 index 0000000..0bd86be --- /dev/null +++ b/CodeGen.sml @@ -0,0 +1,181 @@ +structure CodeGen = +struct + fun enumerate l = ListPair.zip (List.tabulate (length l, (fn x => x)), l) + + (* There are 256 registers *) + val tempReg = 255 + + structure VarMap = Map (type k = Syntax.var + val cmp = Int.compare) + + fun cycle (outputs : Syntax.var VarMap.map) (output : Syntax.var) : Syntax.opcode list = + case VarMap.lookup output outputs of + NONE => Syntax.OShuf (output, Syntax.VVar tempReg) :: cycles outputs + | SOME input => + Syntax.OShuf (output, Syntax.VVar input) :: cycle (VarMap.delete output outputs) input + + and cycles (outputs : Syntax.var VarMap.map) : Syntax.opcode list = + case VarMap.lookupMin outputs of + NONE => [] + | SOME (output, input) => + Syntax.OShuf (tempReg, Syntax.VVar input) :: cycle (VarMap.delete output outputs) input + + fun shuffle' (inputs : unit VarMap.map) (outputs : Syntax.var VarMap.map) : Syntax.opcode list = + case VarMap.lookupMin (VarMap.difference outputs inputs) of + NONE => cycles outputs + | SOME (output, input) => + Syntax.OShuf (output, Syntax.VVar input) :: shuffle' (VarMap.delete input inputs) (VarMap.delete output outputs) + + fun shuffle (args : Syntax.value list) : Syntax.opcode list = + let + val outputMap = + VarMap.fromList + (List.mapPartial + (fn (i, Syntax.VVar v) => + if i = v + then NONE + else SOME (i, v) + | _ => NONE) + (enumerate args)) + val inputMap = + VarMap.fromList + (map + (fn (_, input) => (input, ())) + (VarMap.toList outputMap)) + val constants = + List.mapPartial + (fn (_, Syntax.VVar _) => NONE + | (i, constArg) => SOME (Syntax.OShuf (i, constArg))) + (enumerate args) + in + shuffle' inputMap outputMap @ constants + end + + fun buildVarMap (first : int) (expr : Syntax.cexp) : Syntax.var VarMap.map = + let + val next = ref first + fun insert v m = + let val this = !next + in + next := this + 1; + VarMap.insert v this m + end + fun go expr = + case expr of + Syntax.CRecord (records, k) => + foldl + (fn ((_, res), acc) => insert res acc) + (go k) + records + | Syntax.CSelect (_, _, res, k) => insert res (go k) + | Syntax.CApp _ => VarMap.empty + | Syntax.CFix (funcs, body) => + let + val funcsVars = + foldl + (fn ((_, args, body), acc) => + let + val argsVars = + foldl + (fn ((i, arg), acc) => VarMap.insert arg i acc) + VarMap.empty + (ListPair.zip + (List.tabulate (length args, fn x => x + 1), + args)) + val bodyVars = buildVarMap (length args + 1) body + in VarMap.union (VarMap.union acc argsVars) bodyVars + end) + VarMap.empty + funcs + val bodyVars = go body + in VarMap.union funcsVars bodyVars + end + | Syntax.CPrimop (_, _, res, k) => + let + val resVars = + foldl + (fn (v, acc) => insert v acc) + VarMap.empty + res + val kVars = + foldl + (fn (expr, acc) => VarMap.union acc (go expr)) + VarMap.empty + k + in + VarMap.union resVars kVars + end + in go expr + end + + fun toASM (expr : Syntax.cexp) : Syntax.opcode list = + let + val varMap = buildVarMap 0 expr + fun translate v = + case VarMap.lookup v varMap of + NONE => raise Fail ("unable to translate var " ^ Int.toString v) + | SOME x => x + fun translateVal (Syntax.VVar v) = Syntax.VVar (translate v) + | translateVal x = x + fun go expr = + case expr of + Syntax.CRecord (records, k) => + map (fn (args, res) => Syntax.OAlloc (translate res, Syntax.VInt (length args))) + records + @ List.concat + (map + (fn (args, res) => + List.concat + (map + (fn (i, (arg, path)) => + let val (temp, ops) = + foldl + (fn (off, (arg, ops)) => + (Syntax.VVar tempReg, Syntax.OPeek (tempReg, off, arg) :: ops)) + (translateVal arg, []) + path + in rev (Syntax.OPoke (i, translate res, temp) :: ops) + end) + (enumerate args))) + records) + @ go k + | Syntax.CSelect (i, arg, res, k) => Syntax.OPeek (translate res, i, translateVal arg) :: go k + | Syntax.CApp (func, args) => shuffle (map translateVal (func :: args)) @ [Syntax.OCall] + | Syntax.CFix (funcs, body) => + let + val bodyASM = go body + val funcsASM = + foldl + (fn ((name, _, body), acc) => + Syntax.OLabel name :: go body @ acc) + [] + funcs + in + bodyASM @ funcsASM + end + | Syntax.CPrimop (Syntax.PExit, [arg], _, _) => [Syntax.OExit (translateVal arg)] + | Syntax.CPrimop (Syntax.PAdd, [x, y], [res], [k]) => Syntax.OAdd (translate res, translateVal x, translateVal y) :: go k + | Syntax.CPrimop (Syntax.PSub, [x, y], [res], [k]) => Syntax.OSub (translate res, translateVal x, translateVal y) :: go k + | Syntax.CPrimop (Syntax.PMul, [x, y], [res], [k]) => Syntax.OMul (translate res, translateVal x, translateVal y) :: go k + | Syntax.CPrimop (Syntax.PDiv, [x, y], [res], [k]) => Syntax.ODiv (translate res, translateVal x, translateVal y) :: go k + | Syntax.CPrimop (Syntax.PLess, [x, y], [res], [k]) => Syntax.OLess (translate res, translateVal x, translateVal y) :: go k + | Syntax.CPrimop (Syntax.PEq, [x, y], [res], [k]) => Syntax.OEq (translate res, translateVal x, translateVal y) :: go k + | Syntax.CPrimop (Syntax.PIf, [b], [], [k1, k2]) => + let + val trueLabel = GenSym.new () + in + Syntax.OIf (translateVal b, trueLabel) + :: go k2 + @ Syntax.OLabel trueLabel + :: go k1 + end + | Syntax.CPrimop (Syntax.PRead, [Syntax.VVar ptr, off, len], [res], [k]) => + Syntax.ORead (translate res, translate ptr, translateVal off, translateVal len) :: go k + | Syntax.CPrimop (Syntax.PWrite, [Syntax.VVar ptr, off, len], _, [k]) => + Syntax.OWrite (translate ptr, translateVal off, translateVal len) :: go k + | Syntax.CPrimop (Syntax.PWriteErr, [Syntax.VVar ptr, off, len], _, [k]) => + Syntax.OWriteErr (translate ptr, translateVal off, translateVal len) :: go k + | _ => raise Fail ("malformed CPS:\n" ^ Syntax.cexpToString expr) + in go expr + end +end diff --git a/Compiler.sml b/Compiler.sml new file mode 100644 index 0000000..4c5e238 --- /dev/null +++ b/Compiler.sml @@ -0,0 +1,40 @@ +structure Compiler = +struct + fun compile (prog : Syntax.expr) : Word8Vector.vector = + let + val _ = print ("ast:\n" ^ Syntax.exprToString prog ^ "\n") + val elab = Elab.elaborate prog + val _ = print ("lambda lang:\n" ^ Syntax.lexpToString elab ^ "\n") + val cps = + CPS.toCPS elab + (fn _ => Syntax.CPrimop (Syntax.PExit, [Syntax.VInt 0], [], [])) + val _ = print ("cps1:\n" ^ Syntax.cexpToString cps ^ "\n") + val cps' = CPS.convertClosures cps + val _ = print ("cps:\n" ^ Syntax.cexpToString cps' ^ "\n") + val asm = CodeGen.toASM cps' + val _ = print ("bytecode:\n" ^ String.concatWith "\n" (map Syntax.opcodeToString asm) ^ "\n") + in + Linker.link asm + end + + fun main (args : string list) : unit = + let + val opts = { o = ref "a.out" } + val flags = + [ ("o", Opts.StringOpt (fn arg => #o opts := arg)) ] + val filename = + case Opts.getOpt flags args of + [arg] => arg + | _ => raise Fail "usage: sml [-o ] " + val ast = + case Parser.parse filename of + Result.Left e => + (print e ; + OS.Process.exit OS.Process.failure) + | Result.Right x => x + val bytecode = compile ast + val outFile = BinIO.openOut (!(#o opts)) + in + BinIO.output (outFile, bytecode) + end +end diff --git a/Elab.sml b/Elab.sml new file mode 100644 index 0000000..60760cd --- /dev/null +++ b/Elab.sml @@ -0,0 +1,419 @@ +structure Elab = +struct + structure StringMap = Map(type k = string val cmp = String.compare) + structure IntMap = Map(type k = int val cmp = Int.compare) + + fun primop (s : string) : Syntax.primop = + case s of + "exit" => Syntax.PExit + | "add" => Syntax.PAdd + | "sub" => Syntax.PSub + | "mul" => Syntax.PMul + | "div" => Syntax.PDiv + | "read" => Syntax.PRead + | "write" => Syntax.PWrite + | "writeErr" => Syntax.PWriteErr + | _ => raise Fail ("invalid op: " ^ s) + + fun enumerate (l : 'a list) : (int * 'a) list = + let + fun go _ [] = [] + | go i (x :: xs) = (i, x) :: go (i + 1) xs + in go 0 l + end + + fun hdstls ([] : 'a list list) : ('a list * 'a list list) option = SOME ([], []) + | hdstls ([] :: _) = NONE + | hdstls ((x :: xs) :: ls) = + case hdstls ls of + NONE => NONE + | SOME (heads, tails) => SOME (x :: heads, xs :: tails) + + fun transpose ([] : 'a list list) : 'a list list = [] + | transpose l = + case hdstls l of + NONE => [] + | SOME (heads, tails) => heads :: transpose tails + + datatype env = Env of { vars: int StringMap.map, types: (int * int) StringMap.map, structTypes: env StringMap.map } + + val emptyEnv = Env { vars = StringMap.empty, types = StringMap.empty, structTypes = StringMap.empty } + + fun bindVar (name : string) (sym : int) (Env env) : env = Env { vars = StringMap.insert name sym (#vars env), types = #types env, structTypes = #structTypes env } + + fun lookupVar (name : string) (Env env) : int = + case StringMap.lookup name (#vars env) of + SOME x => x + | NONE => raise Fail ("unbound identifier " ^ name) + + fun bindDataCons (cons : (string * Syntax.etype option) list) (Env env) : env = + let + val nCons = length cons + val (_, vars, types) = + foldl + (fn ((name, _), (i, vars, types)) => + (i + 1, StringMap.insert name (GenSym.new ()) vars, StringMap.insert name (i, nCons) types)) + (0, #vars env, #types env) + cons + in Env { vars = vars, types = types, structTypes = #structTypes env } + end + + fun lookupStructType (name : string) (Env env) : env = + case StringMap.lookup name (#structTypes env) of + SOME x => x + | NONE => raise Fail ("unbound structure " ^ name) + + fun lookupCon ([name] : string list) (Env env) : int option = + Option.map (fn (i, _) => i) (StringMap.lookup name (#types env)) + | lookupCon (structName :: names) env = + lookupCon names (lookupStructType structName env) + | lookupCon [] _ = raise Fail "lookupCon empty" + + fun nConstructors ([name] : string list) (Env env) : int = + let val (_, n) = valOf (StringMap.lookup name (#types env)) + in n + end + | nConstructors (structName :: names) env = + nConstructors names (lookupStructType structName env) + | nConstructors [] _ = raise Fail "nConstructors empty" + + fun patternMatrix (arms : Syntax.pat list) : Syntax.pat list list = + let val ts = + foldl + (fn (Syntax.PWild, tupleSize) => tupleSize + | (Syntax.PVar _, tupleSize) => tupleSize + | (Syntax.PCon _, _) => ~2 + | (Syntax.PInt _, _) => ~2 + | (Syntax.PTuple t, ~1) => length t + | (Syntax.PTuple t, tupleSize) => + if tupleSize = length t + then tupleSize + else raise Fail "a type checker would have caught this") + ~1 + arms + in if ts < 0 + then [arms] + else let + val expandedArms = + map + (fn Syntax.PTuple t => t + | _ => List.tabulate (ts, fn _ => Syntax.PWild)) + arms + val cols = transpose expandedArms + in List.concat (map patternMatrix cols) + end + end + + fun occurrenceVector (expr : Syntax.lexp) (arms : Syntax.pat list) : Syntax.lexp list = + let + val expandedArms = + List.mapPartial + (fn Syntax.PTuple t => SOME t + | _ => NONE) + arms + val cols = transpose expandedArms + in + case cols of + [] => [expr] + | _ => List.concat (map (fn (i, col) => occurrenceVector (Syntax.LSelect (i, expr)) col) (enumerate cols)) + end + + fun patternBindings (expr : Syntax.lexp) (Syntax.PVar v) : (string * Syntax.lexp) list = [(v, expr)] + | patternBindings expr (Syntax.PTuple t) = + List.concat (map (fn (i, p) => patternBindings (Syntax.LSelect (i, expr)) p) (enumerate t)) + | patternBindings expr (Syntax.PCon (_, arg)) = patternBindings (Syntax.LSelect (1, expr)) arg + | patternBindings _ _ = [] + + fun swap1 0 (l : 'a list) : 'a list = l + | swap1 n (first :: rest) = + (case swap1 (n - 1) rest of + x :: rest => x :: first :: rest + | _ => raise Fail "swap1: index out of bounds") + | swap1 _ _ = raise Fail "swap1: index out of bounds" + + fun swap (n : int) (patterns : Syntax.pat list list) (occurrences : Syntax.lexp list) : Syntax.pat list list * Syntax.lexp list = + (map (swap1 n) patterns, swap1 n occurrences) + + fun specialize (env : env) (n : int) (patterns : Syntax.pat list list, occurrences : Syntax.lexp list, actions : Syntax.lexp list) : Syntax.pat list list * Syntax.lexp list * Syntax.lexp list = + let + val con1 = + List.find + (fn Syntax.PCon (name, _) => valOf (lookupCon name env) = n + | _ => false) + (map hd patterns) + val newTupleSize = + case con1 of + SOME (Syntax.PCon (_, Syntax.PTuple t)) => length t + | _ => 0 + val occHead = hd occurrences + val occRest = tl occurrences + val occurrences = + if newTupleSize = 0 + then Syntax.LSelect (1, occHead) :: occRest + else + List.tabulate (newTupleSize, fn i => Syntax.LSelect (i, Syntax.LSelect (1, occHead))) @ occRest + fun specializeRow (Syntax.PInt i :: rest) = + if i = n then SOME (Syntax.PWild :: rest) else NONE + | specializeRow (Syntax.PWild :: rest) = SOME (Syntax.PWild :: rest) + | specializeRow (Syntax.PVar _ :: rest) = SOME (Syntax.PWild :: rest) + | specializeRow (Syntax.PCon (con, Syntax.PTuple []) :: rest) = + specializeRow (Syntax.PCon (con, Syntax.PTuple [Syntax.PWild]) :: rest) + | specializeRow (Syntax.PCon (con, Syntax.PTuple args) :: rest) = + if valOf (lookupCon con env) = n + then SOME (args @ rest) + else NONE + | specializeRow (Syntax.PCon (con, obj) :: rest) = + specializeRow (Syntax.PCon (con, Syntax.PTuple [obj]) :: rest) + | specializeRow _ = raise Fail "unexpected pattern in the matrix" + val (patterns, actions) = + ListPair.unzip + (List.mapPartial + (fn (p, a) => + Option.map (fn p => (p, a)) (specializeRow p)) + (ListPair.zipEq (patterns, actions))) + in (patterns, occurrences, actions) + end + + fun default (patterns : Syntax.pat list list, occurrences : Syntax.lexp list, actions : Syntax.lexp list) : Syntax.pat list list * Syntax.lexp list * Syntax.lexp list = + let + val (patterns, actions) = + ListPair.unzip + (List.filter + (fn (Syntax.PWild :: _, _) => true + | (Syntax.PVar _ :: _, _) => true + | _ => false) + (ListPair.zipEq (patterns, actions))) + in (patterns, occurrences, actions) + end + + fun compilePatternMatching (env : env) ([] : Syntax.pat list list, _ : Syntax.lexp list, _ : Syntax.lexp list) : Syntax.lexp = + raise Fail "nonexhaustive match" + | compilePatternMatching env (patterns as firstRow :: rows, occurrences, actions) = + let val refutablePattern = + List.find + (fn (_, Syntax.PInt _) => true + | (_, Syntax.PCon _) => true + | _ => false) + (enumerate firstRow) + in + case refutablePattern of + NONE => hd actions + | SOME (i, _) => + let + val (patterns, occurrences) = + if i = 0 + then (patterns, occurrences) + else swap i patterns occurrences + val firstCol = map hd patterns + val signatures = + map (fn (x, _) => x) + (IntMap.toList + (foldl + (fn (Syntax.PInt i, acc) => IntMap.insert i true acc + | (Syntax.PCon (c, _), acc) => IntMap.insert (valOf (lookupCon c env)) true acc + | (_, acc) => acc) + IntMap.empty + firstCol)) + val nCons = + case List.find (fn (Syntax.PCon _) => true | _ => false) firstCol of + SOME (Syntax.PCon (name, _)) => nConstructors name env + | _ => ~1 + val defaultCase = + if length signatures = nCons + then NONE + else SOME (compilePatternMatching env (default (patterns, occurrences, actions))) + val switchOperand = + if nCons < 0 + then hd occurrences + else Syntax.LSelect (0, hd occurrences) + in + Syntax.LSwitch + ( switchOperand + , map + (fn i => (i, compilePatternMatching env (specialize env i (patterns, occurrences, actions)))) + signatures + , defaultCase + ) + end + end + + fun declBoundVars (Syntax.DVal (p, _)) : string list = map (fn (x, _) => x) (patternBindings (Syntax.LInt 0) p) + | declBoundVars (Syntax.DValRec (p, _)) = map (fn (x, _) => x) (patternBindings (Syntax.LInt 0) p) + | declBoundVars (Syntax.DFun (name, _)) = [name] + | declBoundVars (Syntax.DDatatype (_, cons)) = map (fn (x, _) => x) cons + | declBoundVars (Syntax.DStruct (name, _)) = [name] + + fun structBoundVars (decls : Syntax.dec list) : string list = List.concatMap declBoundVars decls + + fun bindStructType (name : string) (decls : Syntax.dec list) (Env env) : env = + let + val structEnv = + foldl + (fn (Syntax.DDatatype (_, cons), env) => bindDataCons cons env + | (Syntax.DStruct (name, decls), env) => bindStructType name decls env + | (_, env) => env) + emptyEnv + decls + val structEnv = + foldl + (fn ((i, n), env) => bindVar n i env) + structEnv + (enumerate (structBoundVars decls)) + in + Env { vars = #vars env, types = #types env, structTypes = StringMap.insert name structEnv (#structTypes env) } + end + + fun actionVector (env : env) (expr : Syntax.lexp) (arms : (Syntax.pat * Syntax.expr) list) : Syntax.lexp list = + map + (fn (p, body) => + let + val bindings = patternBindings expr p + val env = + foldl + (fn ((name, _), env) => + bindVar name (GenSym.new ()) env) + env + bindings + in + foldl + (fn ((name, binding), acc) => + Syntax.LApp (Syntax.LFn (lookupVar name env, acc), binding)) + (elab env body) + bindings + end) + arms + + and elabCase (env : env) (expr : Syntax.lexp) (arms : (Syntax.pat * Syntax.expr) list) = + let + val patterns = transpose (patternMatrix (map (fn (x, _) => x) arms)) + val occurrences = occurrenceVector expr (map (fn (x, _) => x) arms) + val actions = actionVector env expr arms + val actionFns = + map + (fn a => (GenSym.new (), GenSym.new (), a)) + actions + val smallActions = + map + (fn (f, _, _) => Syntax.LApp (Syntax.LVar f, Syntax.LInt 0)) + actionFns + in + Syntax.LFix + ( actionFns + , compilePatternMatching env (patterns, occurrences, smallActions) + ) + end + + and elab (env : env) (p : Syntax.expr) : Syntax.lexp = + case p of + Syntax.EIdent [i] => Syntax.LVar (lookupVar i env) + | Syntax.EIdent (structName :: accessors) => + let + val s = Syntax.LVar (lookupVar structName env) + val env = lookupStructType structName env + fun go env [i] acc = Syntax.LSelect (lookupVar i env, acc) + | go env (accessor :: accessors) acc = + let val env = lookupStructType accessor env + in go env accessors (Syntax.LSelect (lookupVar accessor env, acc)) + end + | go _ [] _ = raise Fail "go empty" + in go env accessors s + end + | Syntax.EIdent [] => raise Fail "invalid syntax" + | Syntax.EBuiltin builtin => Syntax.LPrim (primop builtin) + | Syntax.EInt i => Syntax.LInt i + | Syntax.EStr s => Syntax.LString s + | Syntax.ETuple exprs => Syntax.LRecord (map (elab env) exprs) + | Syntax.EList exprs => + foldr + (fn (x, acc) => + Syntax.LRecord [elab env x, acc]) + (Syntax.LInt 0) + exprs + | Syntax.EApp (f, x) => Syntax.LApp (elab env f, elab env x) + | Syntax.ETyped (e, _) => elab env e + | Syntax.EAndAlso (_, _) => raise Fail "unimplemented" + | Syntax.EOrElse (_, _) => raise Fail "unimplemented" + | Syntax.ELet ([], body) => elab env body + | Syntax.ELet (Syntax.DDatatype (name, cons) :: decls, body) => + let + val env = bindDataCons cons env + val funs = + List.mapPartial + (fn (_, (_, NONE)) => NONE + | (i, (name, _)) => + let val v = GenSym.new () + in SOME (lookupVar name env, v, Syntax.LRecord [Syntax.LInt i, Syntax.LVar v]) + end) + (enumerate cons) + val vals = + List.mapPartial + (fn (i, (name, NONE)) => SOME (lookupVar name env, Syntax.LRecord [Syntax.LInt i]) + | _ => NONE) + (enumerate cons) + in + foldl + (fn ((v, x), acc) => + Syntax.LApp (Syntax.LFn (v, acc), x)) + (Syntax.LFix (funs, elab env (Syntax.ELet (decls, body)))) + vals + end + | Syntax.ELet (Syntax.DVal (pat, v) :: decls, body) => + elab env (Syntax.ECase (v, [(pat, Syntax.ELet (decls, body))])) + | Syntax.ELet (Syntax.DValRec (Syntax.PVar name, f as Syntax.ELambda _) :: decls, body) => + let + val n = GenSym.new () + val env = bindVar name n env + val (arg, fnBody) = + case elab env f of + Syntax.LFn x => x + | _ => raise Fail "Syntax.ELambda should expand to Syntax.LFn" + in + Syntax.LFix ([(n, arg, fnBody)], elab env (Syntax.ELet (decls, body))) + end + | Syntax.ELet (Syntax.DValRec _ :: _, _) => raise Fail "invalid val rec" + | Syntax.ELet (Syntax.DFun (name, cases) :: decls, body) => + let + val (ps1, _) = hd cases + val nPats = length ps1 + in if not (List.all (fn (ps, _) => length ps = nPats) cases) + then raise Fail "clauses do not all have same number of patterns" + else let + val n = GenSym.new () + val temps = List.tabulate (nPats, fn _ => GenSym.new ()) + val env = bindVar name n env + val t = GenSym.new () + val innerCase = elabCase env (Syntax.LVar t) (map (fn (ps, b) => (Syntax.PTuple ps, b)) cases) + in + Syntax.LFix + ( [ ( n + , hd temps + , foldr + Syntax.LFn + (Syntax.LApp (Syntax.LFn (t, innerCase), Syntax.LRecord (map Syntax.LVar temps))) + (tl temps) + ) + ] + , elab env (Syntax.ELet (decls, body)) + ) + end + end + | Syntax.ELet (Syntax.DStruct (name, structDecls) :: decls, body) => + let + val names = structBoundVars structDecls + val tuple = elab env (Syntax.ELet (structDecls, Syntax.ETuple (map (fn n => Syntax.EIdent [n]) names))) + val v = GenSym.new () + val env = bindStructType name structDecls env + val env = bindVar name v env + in Syntax.LApp (Syntax.LFn (v, elab env (Syntax.ELet (decls, body))), tuple) + end + | Syntax.ELambda body => + let val v = GenSym.new () + in Syntax.LFn (v, elabCase env (Syntax.LVar v) [body]) + end + | Syntax.ECase (expr, arms) => + let val v = GenSym.new () + in Syntax.LApp (Syntax.LFn (v, elabCase env (Syntax.LVar v) arms), elab env expr) + end + + fun elaborate (p : Syntax.expr) : Syntax.lexp = elab emptyEnv p +end diff --git a/GenSym.sml b/GenSym.sml new file mode 100644 index 0000000..eef7333 --- /dev/null +++ b/GenSym.sml @@ -0,0 +1,5 @@ +structure GenSym = +struct + val counter : int ref = ref 0 + fun new () : int = (counter := (!counter + 1) ; !counter) +end diff --git a/Linker.sml b/Linker.sml new file mode 100644 index 0000000..684451d --- /dev/null +++ b/Linker.sml @@ -0,0 +1,149 @@ +structure Linker = +struct + fun makeOpcode w code arg1Const arg2Const = + if code >= 0x40 + then raise Fail "code is more than 6 bits" + else + let + val arg1Bit = if arg1Const then 2 else 0 + val arg2Bit = if arg2Const then 1 else 0 + in + BinIO.output1 (w, Word8.fromInt (code * 4 + arg1Bit + arg2Bit)) + end + + fun isConst (Syntax.VVar _) = false + | isConst _ = true + + fun lowByte w n = + BinIO.output1 (w, Word8.fromInt (Word.toInt (Word.andb (n, Word.fromInt 0xff)))) + + fun writeInt w i = + let val n = Word.fromInt i + in + (lowByte w (Word.orb (Word.<< (n, Word.fromInt 1), Word.fromInt 0x1)) ; + lowByte w (Word.>> (n, Word.fromInt 7)) ; + lowByte w (Word.>> (n, Word.fromInt 15)) ; + lowByte w (Word.>> (n, Word.fromInt 23)) ; + lowByte w (Word.>> (n, Word.fromInt 31)) ; + lowByte w (Word.>> (n, Word.fromInt 39)) ; + lowByte w (Word.>> (n, Word.fromInt 47)) ; + lowByte w (Word.>> (n, Word.fromInt 55))) + end + + fun writeVar w v = + if v > CodeGen.tempReg + then raise Fail ("var out of range: " ^ Int.toString v) + else lowByte w (Word.fromInt v) + + fun writeOffset w i = + if i < 0 + then raise Fail ("negative offset: " ^ Int.toString i) + else writeInt w i + + structure IntMap = Map(type k = int val cmp = Int.compare) + + fun encode (m : int IntMap.map) (w : BinIO.outstream) (oper : Syntax.opcode) : unit = + let + fun writeValue w (Syntax.VVar v) = writeVar w v + | writeValue w (Syntax.VLabel l) = writeInt w (getOpt (IntMap.lookup l m, 0)) + | writeValue w (Syntax.VInt i) = writeInt w i + in + case oper of + Syntax.OAlloc (r, v) => + (makeOpcode w 1 (isConst v) false ; + writeVar w r ; + writeValue w v) + | Syntax.OCall => + makeOpcode w 2 false false + | Syntax.OPoke (off, p, v) => + (makeOpcode w 3 (isConst v) false ; + writeOffset w off ; + writeVar w p ; + writeValue w v) + | Syntax.OPeek (r, off, v) => + (makeOpcode w 4 (isConst v) false ; + writeVar w r ; + writeOffset w off ; + writeValue w v) + | Syntax.OShuf (r, v) => + (makeOpcode w 5 (isConst v) false ; + writeVar w r ; + writeValue w v) + | Syntax.OExit v => + (makeOpcode w 6 (isConst v) false ; + writeValue w v) + | Syntax.OAdd (r, v1, v2) => + (makeOpcode w 7 (isConst v1) (isConst v2) ; + writeVar w r ; + writeValue w v1 ; + writeValue w v2) + | Syntax.OSub (r, v1, v2) => + (makeOpcode w 8 (isConst v1) (isConst v2) ; + writeVar w r ; + writeValue w v1 ; + writeValue w v2) + | Syntax.OMul (r, v1, v2) => + (makeOpcode w 9 (isConst v1) (isConst v2) ; + writeVar w r ; + writeValue w v1 ; + writeValue w v2) + | Syntax.ODiv (r, v1, v2) => + (makeOpcode w 10 (isConst v1) (isConst v2) ; + writeVar w r ; + writeValue w v1 ; + writeValue w v2) + | Syntax.OLess (r, v1, v2) => + (makeOpcode w 11 (isConst v1) (isConst v2) ; + writeVar w r ; + writeValue w v1 ; + writeValue w v2) + | Syntax.OEq (r, v1, v2) => + (makeOpcode w 12 (isConst v1) (isConst v2) ; + writeVar w r ; + writeValue w v1 ; + writeValue w v2) + | Syntax.OIf (condition, label) => + (makeOpcode w 13 (isConst condition) false ; + writeValue w condition ; + writeValue w (Syntax.VLabel label)) + | Syntax.OLabel _ => () + | Syntax.ORead (r, ptr, off, len) => + (makeOpcode w 14 (isConst off) (isConst len) ; + writeVar w r ; + writeVar w ptr ; + writeValue w off ; + writeValue w len) + | Syntax.OWrite (ptr, off, len) => + (makeOpcode w 15 (isConst off) (isConst len) ; + writeVar w ptr ; + writeValue w off ; + writeValue w len) + | Syntax.OWriteErr (ptr, off, len) => + (makeOpcode w 16 (isConst off) (isConst len) ; + writeVar w ptr ; + writeValue w off ; + writeValue w len) + end + + fun link (program : Syntax.opcode list) : Word8Vector.vector = + let + val (w1, b1) = Buffer.buf () + val labels = + foldl + (fn (x, acc) => + (encode IntMap.empty w1 x ; + case x of + Syntax.OLabel l => IntMap.insert l (Word8ArraySlice.length (!b1)) acc + | _ => acc)) + IntMap.empty + program + val (w, b) = Buffer.buf () + fun go [] = () + | go (oper :: program) = + (encode labels w oper ; + go program) + in + go program ; + Word8ArraySlice.vector (!b) + end +end diff --git a/Map.sml b/Map.sml new file mode 100644 index 0000000..d8b3a37 --- /dev/null +++ b/Map.sml @@ -0,0 +1,186 @@ +(* 🅱️-tree *) +signature MAP = +sig + type key + type 'a map + + val empty : 'a map + val null : 'a map -> bool + val insert : key -> 'a -> 'a map -> 'a map + val lookup : key -> 'a map -> 'a option + val delete : key -> 'a map -> 'a map + val union : 'a map -> 'a map -> 'a map + val intersect : 'a map -> 'a map -> 'a map + val difference : 'a map -> 'b map -> 'a map + val fromList : (key * 'a) list -> 'a map + val toList : 'a map -> (key * 'a) list + val lookupMin : 'a map -> (key * 'a) option +end + +functor Map (type k + val cmp : k * k -> order) :> MAP where type key = k = +struct + type key = k + + datatype 'a map = + Tip + | Two of int * 'a map * key * 'a * 'a map + | Three of int * 'a map * key * 'a * 'a map * key * 'a * 'a map + + val empty : 'a map = Tip + + fun null Tip = true + | null _ = false + + fun height (Tip : 'a map) : int = 0 + | height (Two (h, _, _, _, _)) = h + | height (Three (h, _, _, _, _, _, _, _)) = h + + fun two (l : 'a map) (k : key) (v : 'a) (r : 'a map) : 'a map = + if height l <> height r then raise Fail "two: height mismatch" else + Two (height l + 1, l, k, v, r) + + fun three (a : 'a map) (k1 : key) (v1 : 'a) (b : 'a map) (k2 : key) (v2 : 'a) (c : 'a map) : 'a map = + if not (height a = height b andalso height b = height c) then raise Fail "three: height mismatch" else + Three (height a + 1, a, k1, v1, b, k2, v2, c) + + fun view (Tip : 'a map) : ('a map * key * 'a * 'a map) option = NONE + | view (Two (_, l, k, v, r)) = SOME (l, k, v, r) + | view (Three (h, a, k1, v1, b, k2, v2, c)) = SOME (a, k1, v1, two b k2 v2 c) + + fun lookup (k : key) (m : 'a map) : 'a option = + case view m of + NONE => NONE + | SOME (l, k', v, r) => + case cmp (k, k') of + EQUAL => SOME v + | LESS => lookup k l + | GREATER => lookup k r + + datatype 'a insertResult = + One of 'a map + | Split of 'a map * key * 'a * 'a map + + fun join' (left : 'a map) (k : key) (v : 'a) (right : 'a map) : 'a insertResult = + if height left = height right then + Split (left, k, v, right) + else if height left < height right then + case right of + Tip => raise Fail "unreachable" + | Two (_, rl, rk, rv, rr) => + (case join' left k v rl of + One newNode => One (two newNode rk rv rr) + | Split (left, k, v, right) => One (three left k v right rk rv rr)) + | Three (_, ra, rk1, rv1, rb, rk2, rv2, rc) => + case join' left k v ra of + One newNode => One (three newNode rk1 rv1 rb rk2 rv2 rc) + | Split (left, k, v, right) => Split (two left k v right, rk1, rv1, two rb rk2 rv2 rc) + else + case left of + Tip => raise Fail "unreachable" + | Two (_, ll, lk, lv, lr) => + (case join' lr k v right of + One newNode => One (two ll lk lv newNode) + | Split (left, k, v, right) => One (three ll lk lv left k v right)) + | Three (_, la, lk1, lv1, lb, lk2, lv2, lc) => + case join' lc k v right of + One newNode => One (three la lk1 lv1 lb lk2 lv2 newNode) + | Split (left, k, v, right) => Split (two la lk1 lv1 lb, lk2, lv2, two left k v right) + + fun join (left : 'a map) (k : key) (v : 'a) (right : 'a map) : 'a map = + case join' left k v right of + One node => node + | Split (left, k, v, right) => two left k v right + + fun split (m : 'a map) (k : key) : 'a map * bool * 'a map = + case view m of + NONE => (Tip, false, Tip) + | SOME (l, k', v, r) => + case cmp (k, k') of + EQUAL => (l, true, r) + | LESS => + let val (ll, found, lr) = split l k + in (ll, found, join lr k' v r) + end + | GREATER => + let val (rl, found, rr) = split r k + in (join l k' v rl, found, rr) + end + + fun splitLast (m : 'a map) : 'a map * (key * 'a) = + case view m of + SOME (l, k, v, Tip) => (l, (k, v)) + | SOME (l, k, v, r) => + let val (t', k') = splitLast r + in (join l k v t', k') + end + | NONE => raise Fail "splitLast Tip" + + fun join2 (Tip : 'a map) (tr : 'a map) : 'a map = tr + | join2 tl tr = + let val (tl', (kx, x)) = splitLast tl + in join tl' kx x tr + end + + fun delete (k : key) (m : 'a map) : 'a map = + let val (tl, _, tr) = split m k + in join2 tl tr + end + + fun union (Tip : 'a map) (t2 : 'a map) : 'a map = t2 + | union t1 t2 = + case view t2 of + NONE => t1 + | SOME (l2, k2, v2, r2) => + let + val (l1, _, r1) = split t1 k2 + val tl = union l1 l2 + val tr = union r1 r2 + in join tl k2 v2 tr + end + + fun intersect (Tip : 'a map) (_ : 'a map) : 'a map = Tip + | intersect t1 t2 = + case view t2 of + NONE => Tip + | SOME (l2, k2, v2, r2) => + let + val (l1, b, r1) = split t1 k2 + val tl = intersect l1 l2 + val tr = intersect r1 r2 + in + if b then join tl k2 v2 tr + else join2 tl tr + end + + fun difference (Tip : 'a map) (_ : 'b map) : 'a map = Tip + | difference t1 t2 = + case view t2 of + NONE => t1 + | SOME (l2, k2, _, r2) => + let + val (l1, _, r1) = split t1 k2 + val tl = difference l1 l2 + val tr = difference r1 r2 + in join2 tl tr + end + + fun singleton (k : key) (v : 'a) : 'a map = two Tip k v Tip + + fun insert (k : key) (v : 'a) (m : 'a map) : 'a map = union m (singleton k v) + + fun fromList (l : (key * 'a) list) : 'a map = foldl (fn ((kx, x), acc) => insert kx x acc) empty l + + fun toList' (m : 'a map) (acc : (key * 'a) list) : (key * 'a) list = + case view m of + NONE => acc + | SOME (l, k, v, r) => toList' l ((k, v) :: toList' r acc) + + fun toList (m : 'a map) : (key * 'a) list = toList' m [] + + fun lookupMin (m : 'a map) : (key * 'a) option = + case view m of + NONE => NONE + | SOME (Tip, k, v, _) => SOME (k, v) + | SOME (l, _, _, _) => lookupMin l +end diff --git a/Opts.sml b/Opts.sml new file mode 100644 index 0000000..f5be8c4 --- /dev/null +++ b/Opts.sml @@ -0,0 +1,81 @@ +structure Opts = +struct + datatype 'a optDesc = BoolOpt of bool -> unit + | StringOpt of string -> unit + + structure StringMap = Map(type k = string val cmp = String.compare) + + fun error (msg : string) : 'a = + (print msg ; + OS.Process.exit (OS.Process.failure)) + + fun boolFromString s = + case s of + "1" => true + | "t" => true + | "T" => true + | "true" => true + | "TRUE" => true + | "True" => true + | "0" => false + | "f" => false + | "F" => false + | "false" => false + | "FALSE" => false + | "False" => false + | _ => error "invalid boolean value" + + fun getOpt (desc : (string * 'a optDesc) list) (args : string list) : string list = + let + val parsers = StringMap.fromList desc + fun go [] = [] + | go (arg :: args) = + if arg = "-" orelse not (String.isPrefix "-" arg) + then arg :: args + else if arg = "--" + then args + else + let + val name = + if String.isPrefix "--" arg + then String.extract (arg, 2, NONE) + else String.extract (arg, 1, NONE) + val _ = + if String.isPrefix "-" name orelse String.isPrefix "=" name + then error "bad flag syntax" + else () + (* It's a flag. Does it have an argument? *) + val (name', value) = + case CharVector.findi (fn (_, x) => x = #"=") name of + SOME (i, _) => (substring (name, 0, i), String.extract (name, i + 1, NONE)) + | NONE => (name, "") + val parser = + case StringMap.lookup name' parsers of + SOME x => x + | NONE => error ("flag provided but not defined: " ^ String.toString name') + in + case parser of + BoolOpt func => + if value = "" + then + (func true ; + go args) + else + (func (boolFromString value) ; + go args) + | StringOpt func => + (* It must have a value, which might be the next argument. *) + if value = "" andalso not (null args) + then + (func (hd args) ; + go (tl args)) + else if value = "" + then error ("flag needs an argument: " ^ String.toString name') + else + (func value ; + go args) + end + in + go args + end +end diff --git a/Parser.sml b/Parser.sml new file mode 100644 index 0000000..e464332 --- /dev/null +++ b/Parser.sml @@ -0,0 +1,672 @@ +infix 4 <$> <$ +infix 1 >> +infixr 1 <|> +infix 0 + +structure Parser = +struct + structure StringMap = Map(type k = string val cmp = String.compare) + + (* vector of length 10, holding the left and right associative infix operators for each precedence level. *) + type infixTable = (string list * string list) vector + type userState = {infixTable : infixTable} + type sourceLoc = {file : string, row : int, column : int} + type state = {stream : TextIO.StreamIO.instream, loc : sourceLoc, userState : userState} + datatype response = Consumed | Empty + datatype message = Unexpected of string | Expected of string + type parseError = {loc : sourceLoc, msgs : message list} + datatype hints = Hints of string list + type 'a parser = state -> response * (parseError, 'a * state * hints) Result.either + + val reservedWords = + [ "abstype", "and", "andalso", "as", "case", "datatype", "do", "else" + , "end", "exception", "fn", "fun", "handle", "if", "in", "infix" + , "infixr", "let", "local", "nonfix", "of", "op", "open", "orelse" + , "raise", "rec", "then", "type", "val", "with", "withtype", "while" + , "(", ")", "[", "]", "{", "}", ",", ":", ";", "...", "_", "|", "=", "=>", "->", "#" + , "eqtype", "functor", "include", "sharing", "sig" + , "signature", "struct", "structure", "where", ":>" + ] + + val emptyInfixOperators : infixTable = + Vector.tabulate (10, fn _ => ([], [])) + + fun printSourceLoc ({file, row, column} : sourceLoc) : string = + file ^ ":" ^ Int.toString row ^ "." ^ Int.toString column + + fun printError ({loc, msgs} : parseError) : string = + let + val unexpect = List.mapPartial (fn Unexpected x => SOME x | _ => NONE) msgs + val showUnexpect = case unexpect of + [] => "" + | s :: _ => "unexpected " ^ s ^ ";\n" + val expect = List.mapPartial (fn Expected s => SOME s | _ => NONE) msgs + in + printSourceLoc loc ^ " Syntax error:\n" + ^ showUnexpect + ^ "expecting " ^ String.concatWith ", " expect + end + + fun unpackParserResponse (_ : response, Result.Left err : (parseError, 'a * state * hints) Result.either) : (string, 'a) Result.either = + Result.Left (printError err) + | unpackParserResponse (_, Result.Right (a, st, _)) = + if TextIO.StreamIO.endOfStream (#stream st) + then Result.Right a + else Result.Left (printSourceLoc (#loc st) ^ " Syntax error: trailing characters") + + fun newLoc (fileName : string) : sourceLoc = { + file = fileName, + row = 1, + column = 1 + } + + fun collectInfixOperators (opTable : (string list * string list) vector) : string list = + Vector.foldl (fn ((a, b), acc) => a @ b @ acc) [] opTable + + fun infixOps (opTable : infixTable) : string list = + Vector.foldl (fn ((a, b), acc) => a @ b @ acc) [] opTable + + fun newState (fileName : string) (fileStream : TextIO.instream) : state = { + stream = TextIO.getInstream fileStream, + loc = newLoc fileName, + userState = {infixTable = emptyInfixOperators} + } + + fun updateUserState (f : userState -> userState) : userState parser = + fn {stream, loc, userState} => + let val st' = f userState + in (Empty, Result.Right (st', {stream = stream, loc = loc, userState = st'}, Hints [])) + end + + val getUserState : userState parser = updateUserState (fn x => x) + + fun runParser (p : 'a parser) (fileName : string) : (string, 'a) Result.either = + unpackParserResponse (p (newState fileName (TextIO.openIn fileName))) + + fun testParser (p : 'a parser) (s : string) : 'a = + case unpackParserResponse (p (newState "STRING" (TextIO.openString s))) of + Result.Right x => x + | Result.Left e => raise Fail ("Parse failed: " ^ e) + + fun mergeHints (Hints a) (Hints b) : hints = Hints (a @ b) + + fun withHints (Hints hints) ({loc, msgs} : parseError) : parseError = { + loc = loc, + msgs = map Expected hints @ msgs + } + + fun errToHints ({msgs, ...} : parseError) : hints = Hints (List.mapPartial (fn Expected s => SOME s | _ => NONE) msgs) + + fun compareLoc (l : sourceLoc, m : sourceLoc) : order = + case Int.compare (#row l, #row m) of + EQUAL => Int.compare (#column l, #column m) + | ord => ord + + fun mergeError (e1 : parseError) (e2 : parseError) : parseError = + (* pick the longest match *) + case compareLoc (#loc e1, #loc e2) of + EQUAL => { + loc = #loc e1, + msgs = #msgs e1 @ #msgs e2 + } + | GREATER => e1 + | LESS => e2 + + fun bind (p : 'a parser) (f : 'a -> 'b parser) : 'b parser = + fn st => + case p st of + (consumed1, Result.Right (a, st', hints)) => + (case (f a) st' of + (Consumed, Result.Right success) => (Consumed, Result.Right success) + | (Empty, Result.Right (b, st'', hints')) => (consumed1, Result.Right (b, st'', mergeHints hints hints')) + | (Consumed, Result.Left err) => (Consumed, Result.Left (withHints hints err)) + | (Empty, Result.Left err) => (consumed1, Result.Left (withHints hints err))) + | (consumed, Result.Left err) => (consumed, Result.Left err) + + fun (p1 : 'a parser) >> (p2 : 'b parser) : 'b parser = bind p1 (fn _ => p2) + + fun (p : 'a parser) (msg : string) : 'a parser = + fn st => + case p st of + (consumed, Result.Right (a, st', _)) => (consumed, Result.Right (a, st', Hints [msg])) + | (consumed, Result.Left {loc, ...}) => (consumed, Result.Left {loc = loc, msgs = [Expected msg]}) + + fun (p1 : 'a parser) <|> (p2 : 'a parser) : 'a parser = + fn st => + case p1 st of + (Empty, Result.Left err) => + (case p2 st of + (Empty, Result.Right (a, st', hints)) => (Empty, Result.Right (a, st', mergeHints (errToHints err) hints)) + | (Empty, Result.Left err') => (Empty, Result.Left (mergeError err err')) + | res => res) + | res => res + + fun const (x : 'a) (st : state) = (Empty, Result.Right (x, st, Hints [])) + + fun (f : 'a -> 'b) <$> (p : 'a parser) : 'b parser = bind p (const o f) + + fun (x : 'a) <$ (p : 'b parser) : 'a parser = (fn _ => x) <$> p + + fun try (p : 'a parser) : 'a parser = + fn st => + case p st of + (Consumed, Result.Left err) => (Empty, Result.Left err) + | res => res + + fun updatePosChar ({file, row, column} : sourceLoc) (c : char) : sourceLoc = + case c of + #"\n" => { + file = file, + row = row + 1, + column = 1 + } + | #"\t" => { + file = file, + row = row, + column = column + 8 - (column - 1) mod 8 + } + | _ => { + file = file, + row = row, + column = column + 1 + } + + fun satisfy (pred : char -> bool) : char parser = + fn {stream, loc, userState} => + case TextIO.StreamIO.input1 stream of + NONE => (Empty, Result.Left {loc = loc, msgs = [Expected "UNKNOWN"]}) + | SOME (c, stream') => + if pred c + then (Consumed, Result.Right (c, {stream = stream', loc = updatePosChar loc c, userState = userState}, Hints [])) + else (Empty, Result.Left {loc = loc, msgs = [Expected "UNKNOWN"]}) + + fun parseChar (c : char) : char parser = + satisfy (fn c' => c = c') str c + + fun parseString (s : string) : string parser = + case explode s of + [] => const "" + | c1 :: cs => s <$ foldl (fn (c, p) => p >> parseChar c) (parseChar c1) cs "'" ^ String.toString s ^ "'" + + fun manyErr () = raise Fail "many is applied to a parser that accepts an empty string" + + fun many (p : 'a parser) : 'a list parser = + fn st => + let fun walk xs s' = + case p s' of + (Consumed, Result.Right (x, s'', _)) => walk (x :: xs) s'' + | (Consumed, Result.Left err) => (Consumed, Result.Left err) + | (Empty, Result.Right _) => manyErr () + | (Empty, Result.Left err) => (Consumed, Result.Right (rev xs, s', errToHints err)) + in + case p st of + (Consumed, Result.Right (x, s', _)) => walk [x] s' + | (Consumed, Result.Left err) => (Consumed, Result.Left err) + | (Empty, Result.Right _) => manyErr () + | (Empty, Result.Left err) => (Empty, Result.Right ([], st, errToHints err)) + end + + fun many1 (p : 'a parser) : 'a list parser = + bind p (fn x => + bind (many p) (fn xs => + const (x :: xs))) + + val space : char parser = satisfy Char.isSpace "space" + + val spaces : unit parser = () <$ many space "white space" + + fun unexpected (s : string) : 'a parser = + fn {loc, ...} => (Empty, Result.Left {loc = loc, msgs = [Unexpected s]}) + + val letter : char parser = satisfy Char.isAlpha "letter" + + val alphaNum : char parser = satisfy Char.isAlphaNum "letter or digit" + + fun oneOf ([] : char list) : char parser = raise Fail "oneOf empty" + | oneOf (x :: xs) = foldl (fn (c, p) => p <|> parseChar c) (parseChar x) xs + + (* some day, whiteSpace will support comments *) + val whiteSpace = spaces + + fun lexeme (p : 'a parser) : 'a parser = + bind p (fn x => + whiteSpace >> + const x) + + val alphaNumIdentifierLetter : char parser = + alphaNum <|> oneOf [#"'", #"_"] + + val symbolicIdentifierLetters : char list = + [ #"!", #"%", #"&", #"$", #"#", #"+", #"-", #"/", #":", #"<" + , #"=", #">", #"?", #"@", #"\\", #"~", #"`", #"^", #"|", #"*" + ] + + val symbolicIdentifierLetter : char parser = oneOf symbolicIdentifierLetters + + val alphaNumIdentifier : string parser = + lexeme + (bind letter (fn firstLetter => + bind (many alphaNumIdentifierLetter) (fn rest => + const (implode (firstLetter :: rest))))) + + val tyvar : string parser = + lexeme + (bind (parseChar #"'") (fn firstLetter => + bind (many alphaNumIdentifierLetter) (fn rest => + const (implode (firstLetter :: rest))))) + + val symbolicIdentifier : string parser = + lexeme + (implode <$> many1 symbolicIdentifierLetter) + + fun notReserved (reserved : string list) : string parser = + try + (bind (alphaNumIdentifier <|> symbolicIdentifier "identifier") (fn identName => + if List.exists (fn n => n = identName) reserved + then unexpected identName + else const identName)) + + val identifier : string parser = + bind getUserState (fn {infixTable, ...} => + notReserved (infixOps infixTable @ reservedWords)) + + val tycon : string parser = + bind getUserState (fn st => + notReserved ("*" :: reservedWords)) + + fun sepBy1 (p : 'a parser) (sep : 'b parser) : 'a list parser = + bind p (fn x => + bind (many (sep >> p)) (fn xs => + const (x :: xs))) + + fun sepBy (p : 'a parser) (sep : 'b parser) : 'a list parser = + sepBy1 p sep <|> const [] + + fun symbol (s : string) : string parser = lexeme (parseString s) + + val longIdentifier : string list parser = sepBy1 identifier (symbol ".") + + fun notFollowedBy (p : char parser) : unit parser = + bind (try p) (fn c => unexpected (str c)) + <|> const () + + fun reserved (s : string) : string parser = + let + val start = + if s = "" + then raise Fail "reserved was called on an empty string" + else String.sub (s, 0) + val isSymbolic = + List.exists (fn c => c = start) symbolicIdentifierLetters + in + lexeme + (try + (parseString s >> + notFollowedBy (if isSymbolic then symbolicIdentifierLetter else alphaNumIdentifierLetter) >> + const s)) + s + end + + val infixIdentifier : string parser = + bind getUserState (fn {infixTable, ...} => + let val ops = map reserved (Vector.foldl (fn ((l, r), acc) => l @ r @ acc) [] infixTable) + in + case ops of + [] => unexpected "infix op" + | x :: xs => foldl op <|> x xs "infix op" + end) + + val longInfixIdentifier : string list parser = + bind (many (bind identifier (fn id => symbol "." >> const id))) (fn idents => + bind infixIdentifier (fn ii => + const (idents @ [ii]))) + + val digit : char parser = satisfy Char.isDigit "digit" + + val integer : int parser = + lexeme + (bind (many1 digit) (fn digits => + const (valOf (Int.fromString (implode digits))))) + + val stringInternalChar : char parser = + (parseString "\\" >> (#"\a" <$ parseChar #"a" + <|> #"\b" <$ parseChar #"b" + <|> #"\t" <$ parseChar #"t" + <|> #"\n" <$ parseChar #"n" + <|> #"\v" <$ parseChar #"v" + <|> #"\f" <$ parseChar #"f" + <|> #"\r" <$ parseChar #"r" + <|> parseChar #"\"" + <|> parseChar #"\\") "string escape") + <|> (satisfy (fn c => c <> #"\"" andalso c <> #"\\") "string character") + + val stringConstant : string parser = + lexeme + (parseString "\"" >> + bind (implode <$> many stringInternalChar) (fn stringContent => + parseString "\"" >> + const stringContent)) + + val builtin : Syntax.expr parser = + reserved "__builtin" >> + Syntax.EBuiltin <$> stringConstant + + fun between (left : 'a parser) (right : 'b parser) (p : 'c parser) : 'c parser = + left >> + bind p (fn x => + right >> + const x) + + fun parseTycons (ty : Syntax.etype) : Syntax.etype parser = + bind tycon (fn longtycon => + parseTycons (Syntax.Tycon ([ty], longtycon))) + <|> const ty + + val rec parseSingleType : Syntax.etype parser = fn st => + (Syntax.Tyvar <$> (tyvar <|> tycon) + <|> bind (between (symbol "(") (symbol ")") (sepBy1 parseType (symbol ","))) (fn types => + case types of + [x] => const x + | _ => bind tycon (fn longtycon => + const (Syntax.Tycon (types, longtycon))))) st + and parseTycon : Syntax.etype parser = + fn st => + bind parseSingleType parseTycons st + and parseTupleType : Syntax.etype parser = + fn st => + bind (sepBy1 parseTycon (reserved "*")) (fn types => + const + (case types of + [ty] => ty + | _ => Syntax.TyTuple types)) st + and parseType : Syntax.etype parser = + fn st => + bind parseTupleType (fn ty => + (reserved "->" >> + bind parseType (fn ty' => + const (Syntax.Tyfun (ty, ty')))) + <|> const ty) st + + fun leftOp (i : int) : string parser = + bind getUserState (fn {infixTable, ...} => + let val (leftOps, _) = Vector.sub (infixTable, i) + in + case (map reserved leftOps) of + [] => unexpected "left-associative operator" + | op1 :: ops => (fn x => x) <$> foldl op <|> op1 ops + end) + + fun rightOp (i : int) : string parser = + bind getUserState (fn {infixTable, ...} => + let val (_, rightOps) = Vector.sub (infixTable, i) + in + case (map reserved rightOps) of + [] => unexpected "right-associative operator" + | op1 :: ops => (fn x => x) <$> foldl op <|> op1 ops + end) + + val rec atpat : Syntax.pat parser = fn st => + (Syntax.PWild <$ reserved "_" + <|> Syntax.PInt <$> integer + <|> bind (between (symbol "(") (symbol ")") (sepBy pat (symbol ","))) (fn pats => + const + (case pats of + [p] => p + | _ => Syntax.PTuple pats)) + <|> bind longIdentifier (fn [i] => const (Syntax.PVar i) | is => const (Syntax.PCon (is, Syntax.PTuple [])))) st + and appPat : Syntax.pat parser = fn st => + (bind longIdentifier (fn ident => + bind atpat (fn arg => + const (Syntax.PCon (ident, arg))) + <|> const (case ident of + [i] => Syntax.PVar i + | _ => Syntax.PCon (ident, Syntax.PTuple []))) + <|> atpat) st + and pat : Syntax.pat parser = fn st => + foldl + (fn (i, patLower) => + let + fun patLeft pat1 = + bind (leftOp i) (fn opEx => + bind patLower (fn pat2 => + let val app = Syntax.PCon ([opEx], Syntax.PTuple [pat1, pat2]) + in patLeft app <|> const app + end)) + fun patRight pat1 = + bind (rightOp i) (fn opEx => + bind patLower (fn pat2 => + bind (patRight pat2 <|> const pat2) (fn rest => + const (Syntax.PCon ([opEx], Syntax.PTuple [pat1, rest]))))) + in + bind patLower (fn pat1 => + patLeft pat1 <|> patRight pat1 <|> const pat1) + end) + appPat + (List.tabulate (10, fn i => 9 - i)) st + + val rec atom : Syntax.expr parser = + fn st => + (Syntax.EInt <$> integer + <|> Syntax.EStr <$> stringConstant + <|> Syntax.EIdent <$> longIdentifier + <|> (reserved "op" >> Syntax.EIdent <$> longInfixIdentifier) + <|> builtin + <|> (reserved "let" >> + bind (many dec) (fn decs => + reserved "in" >> + bind expr (fn e => + reserved "end" >> + const (Syntax.ELet (List.mapPartial (fn x => x) decs, e))))) + <|> (symbol "(" >> + bind (sepBy expr (symbol ",")) (fn exprs => + symbol ")" >> + const + (case exprs of + [x] => x + | _ => Syntax.ETuple exprs)))) st + and appExp : Syntax.expr parser = + fn st => + bind atom (fn e0 => + foldl (fn (x, acc) => Syntax.EApp (acc, x)) e0 <$> many atom) st + and infixExp : Syntax.expr parser = + fn st => + foldl + (fn (i, exprLower) => + let + fun exprLeft expr1 = + bind (leftOp i) (fn opEx => + bind exprLower (fn expr2 => + let val app = Syntax.EApp (Syntax.EIdent [opEx], Syntax.ETuple [expr1, expr2]) + in exprLeft app <|> const app + end)) + fun exprRight expr1 = + bind (rightOp i) (fn opEx => + bind exprLower (fn expr2 => + bind (exprRight expr2 <|> const expr2) (fn rest => + const (Syntax.EApp (Syntax.EIdent [opEx], Syntax.ETuple [expr1, rest]))))) + in + bind exprLower (fn expr1 => + exprLeft expr1 <|> exprRight expr1 <|> const expr1) + end) + appExp + (List.tabulate (10, fn i => 9 - i)) st + and typedExp : Syntax.expr parser = + fn st => + bind infixExp (fn e => + (reserved ":" >> + bind parseType (fn ty => + const (Syntax.ETyped (e, ty)))) + <|> const e) st + and andalsoExp : Syntax.expr parser = + fn st => + bind typedExp (fn e1 => + (reserved "andalso" >> + bind andalsoExp (fn e2 => + const (Syntax.EAndAlso (e1, e2)))) + <|> const e1) st + and orelseExpr : Syntax.expr parser = + fn st => + bind andalsoExp (fn e1 => + (reserved "orelse" >> + bind orelseExpr (fn e2 => + const (Syntax.EOrElse (e1, e2)))) + <|> const e1) st + and expr : Syntax.expr parser = fn st => + ((reserved "fn" >> + bind pat (fn p => + reserved "=>" >> + bind expr (fn e => + const (Syntax.ELambda (p, e))))) + <|> (reserved "case" >> + bind expr (fn e => + reserved "of" >> + bind + (sepBy1 + (bind pat (fn p => + reserved "=>" >> + bind expr (fn e => + const (p, e)))) + (reserved "|")) (fn arms => + const (Syntax.ECase (e, arms))))) + <|> orelseExpr) st + and dec : Syntax.dec option parser = fn st => + (bind (false <$ reserved "infix" <|> true <$ reserved "infixr") (fn direction => + bind (integer <|> const 0) (fn level => + bind (many1 identifier) (fn ops => + updateUserState + (fn {infixTable} => + let val (leftOps, rightOps) = Vector.sub (infixTable, level) + in + if direction + then {infixTable = Vector.update (infixTable, level, (leftOps, ops @ rightOps))} + else {infixTable = Vector.update (infixTable, level, (ops @ leftOps, rightOps))} + end) >> + const NONE))) + <|> (reserved "datatype" >> + (between (symbol "(") (symbol ")") (sepBy1 tyvar (symbol ",")) + <|> (fn x => [x]) <$> tyvar + <|> const []) >> + bind identifier (fn name => + reserved "=" >> + bind + (sepBy1 + (bind (infixIdentifier <|> identifier) (fn con => + (reserved "of" >> + bind parseType (fn ty => + const (con, SOME ty))) + <|> const (con, NONE))) + (reserved "|")) (fn cons => + const (SOME (Syntax.DDatatype (name, cons)))))) + <|> (reserved "val" >> + bind (true <$ reserved "rec" <|> const false) (fn isRec => + bind pat (fn p => + reserved "=" >> + bind expr (fn e => + const + (SOME + (if isRec + then Syntax.DValRec (p, e) + else Syntax.DVal (p, e))))))) + <|> (reserved "fun" >> + bind + (sepBy1 + (bind (bind atpat (fn pat1 => + bind infixIdentifier (fn infixOp => + bind atpat (fn pat2 => + const (infixOp, [Syntax.PTuple [pat1, pat2]]))) + <|> (case pat1 of + Syntax.PVar name => + bind (many1 atpat) (fn args => + const (name, args)) + | _ => unexpected "pattern"))) (fn (name, args) => + reserved "=" >> + bind expr (fn body => + const (name, args, body)))) + (reserved "|")) (fn cases => + let val (name, _, _) = hd cases + in + if not (List.all (fn (n, _, _) => n = name) cases) + then raise Fail "clauses do not all have same function name" + else const (SOME (Syntax.DFun (name, map (fn (_, x, y) => (x, y)) cases))) + end))) st + + val rec strdec : Syntax.dec option parser = fn st => + ((reserved "structure" >> + bind identifier (fn strID => + reserved "=" >> + reserved "struct" >> + bind (many strdec) (fn bindings => + reserved "end" >> + const (SOME (Syntax.DStruct (strID, List.mapPartial (fn x => x) bindings)))))) + <|> dec) st + + (* There's ambiguity between pattern variables and constructors that can only + * be resolved by checking for constructors in scope *) + fun fixPatConstructors (constructors : unit StringMap.map) (Syntax.PVar v) : Syntax.pat = + if isSome (StringMap.lookup v constructors) + then Syntax.PCon ([v], Syntax.PTuple []) + else Syntax.PVar v + | fixPatConstructors constructors (Syntax.PTuple pats) = Syntax.PTuple (map (fixPatConstructors constructors) pats) + | fixPatConstructors constructors (Syntax.PCon (con, arg)) = Syntax.PCon (con, fixPatConstructors constructors arg) + | fixPatConstructors _ pat = pat + + fun findConstructors (Syntax.DDatatype (_, cases)) : string list = + List.mapPartial + (fn (constructor, NONE) => SOME constructor + | _ => NONE) + cases + | findConstructors _ = [] + + fun fixDecConstructors (constructors : unit StringMap.map) (Syntax.DVal (pat, body)) : Syntax.dec = + Syntax.DVal (fixPatConstructors constructors pat, fixConstructors constructors body) + | fixDecConstructors constructors (Syntax.DValRec (pat, body)) = + Syntax.DValRec (fixPatConstructors constructors pat, fixConstructors constructors body) + | fixDecConstructors constructors (Syntax.DFun (f, arms)) = + Syntax.DFun (f, map (fn (args, body) => (map (fixPatConstructors constructors) args, fixConstructors constructors body)) arms) + | fixDecConstructors _ (decl as Syntax.DDatatype _) = decl + | fixDecConstructors constructors (Syntax.DStruct (name, decs)) = + let + val constructors = ref constructors + val decs : Syntax.dec list = + map + (fn dec => + (constructors := foldl (fn (x, acc) => StringMap.insert x () acc) (!constructors) (findConstructors dec) ; + fixDecConstructors (!constructors) dec)) + decs + in Syntax.DStruct (name, decs) + end + + and fixConstructors (constructors : unit StringMap.map) (Syntax.ETuple exprs) : Syntax.expr = + Syntax.ETuple (map (fixConstructors constructors) exprs) + | fixConstructors constructors (Syntax.EList exprs) = + Syntax.EList (map (fixConstructors constructors) exprs) + | fixConstructors constructors (Syntax.EApp (func, arg)) = + Syntax.EApp (fixConstructors constructors func, fixConstructors constructors arg) + | fixConstructors constructors (Syntax.ETyped (expr, ty)) = + Syntax.ETyped (fixConstructors constructors expr, ty) + | fixConstructors constructors (Syntax.EAndAlso (e1, e2)) = + Syntax.EAndAlso (fixConstructors constructors e1, fixConstructors constructors e2) + | fixConstructors constructors (Syntax.EOrElse (e1, e2)) = + Syntax.EOrElse (fixConstructors constructors e1, fixConstructors constructors e2) + | fixConstructors constructors (Syntax.ELet (decs, body)) = + let + val constructors = ref constructors + val decs = + map + (fn dec => + (constructors := foldl (fn (x, acc) => StringMap.insert x () acc) (!constructors) (findConstructors dec) ; + fixDecConstructors (!constructors) dec)) + decs + in Syntax.ELet (decs, fixConstructors (!constructors) body) + end + | fixConstructors constructors (Syntax.ELambda (pat, body)) = + Syntax.ELambda (fixPatConstructors constructors pat, fixConstructors constructors body) + | fixConstructors constructors (Syntax.ECase (expr, arms)) = + Syntax.ECase (fixConstructors constructors expr, map (fn (pat, expr) => (fixPatConstructors constructors pat, fixConstructors constructors expr)) arms) + | fixConstructors _ expr = expr + + val program : Syntax.expr parser = + bind (many strdec) (fn decs => + const (fixConstructors StringMap.empty (Syntax.ELet (List.mapPartial (fn x => x) decs, Syntax.EInt 0)))) + fun parse (f : string) : (string, Syntax.expr) Result.either = runParser program f +end diff --git a/Result.sml b/Result.sml new file mode 100644 index 0000000..ff1a9a3 --- /dev/null +++ b/Result.sml @@ -0,0 +1,4 @@ +structure Result = +struct + datatype ('a, 'b) either = Left of 'a | Right of 'b +end diff --git a/Sort.sml b/Sort.sml new file mode 100644 index 0000000..d9a70e9 --- /dev/null +++ b/Sort.sml @@ -0,0 +1,24 @@ +signature SORT = +sig + val sort : ('a * 'a -> order) -> 'a list -> 'a list +end + +structure Sort :> SORT = +struct + fun merge (_ : 'a * 'a -> order) ([] : 'a list) (l2 : 'a list) : 'a list = l2 + | merge _ l1 [] = l1 + | merge cmp (xl as x :: xs) (yl as y :: ys) = + (case cmp (x, y) of + GREATER => y :: merge cmp xl ys + | _ => x :: merge cmp xs yl) + + fun sort (_ : 'a * 'a -> order) ([] : 'a list) : 'a list = [] + | sort _ [x] = [x] + | sort cmp l = + let + val n = length l + val half1 = List.take (l, n div 2) + val half2 = List.drop (l, n div 2) + in merge cmp (sort cmp half1) (sort cmp half2) + end +end diff --git a/Syntax.sml b/Syntax.sml new file mode 100644 index 0000000..2f7a96e --- /dev/null +++ b/Syntax.sml @@ -0,0 +1,231 @@ +structure Syntax = +struct + (* SML syntax *) + datatype etype = + Tyvar of string + | Tycon of etype list * string + | TyTuple of etype list + | Tyfun of etype * etype + + datatype pat = + PWild + | PVar of string + | PInt of int + | PTuple of pat list + | PCon of string list * pat + + datatype expr = + EIdent of string list + | EBuiltin of string + | EInt of int + | EStr of string + | ETuple of expr list + | EList of expr list + | EApp of expr * expr + | ETyped of expr * etype + | EAndAlso of expr * expr + | EOrElse of expr * expr + | ELet of dec list * expr + | ELambda of pat * expr + | ECase of expr * (pat * expr) list + + and dec = + DVal of pat * expr + | DValRec of pat * expr + | DFun of string * (pat list * expr) list + | DDatatype of string * (string * etype option) list + | DStruct of string * dec list + + (* Lambda language *) + type var = int + + datatype primop = + PExit + | PAdd + | PSub + | PMul + | PDiv + | PLess + | PEq + | PIf + | PRead + | PWrite + | PWriteErr + + datatype lexp = + LVar of var + | LFn of var * lexp + | LFix of (var * var * lexp) list * lexp + | LApp of lexp * lexp + | LInt of int + | LString of string + | LRecord of lexp list + | LSelect of int * lexp + | LPrim of primop + | LSwitch of lexp * (int * lexp) list * lexp option + + (* CPS *) + datatype value = + VVar of var + | VLabel of var + | VInt of int + + datatype cexp = + CRecord of ((value * int list) list * var) list * cexp + | CSelect of int * value * var * cexp + | CApp of value * value list + | CFix of (var * var list * cexp) list * cexp + | CPrimop of primop * value list * var list * cexp list + + datatype opcode = + OAlloc of var * value + | OCall + | OPoke of int * var * value + | OPeek of var * int * value + | OShuf of var * value + | OExit of value + | OAdd of var * value * value + | OSub of var * value * value + | OMul of var * value * value + | ODiv of var * value * value + | OLess of var * value * value + | OEq of var * value * value + | OIf of value * var + | OLabel of var + | ORead of var * var * value * value + | OWrite of var * value * value + | OWriteErr of var * value * value + + fun listToString (show : 'a -> string) (l : 'a list) = + "[" ^ String.concatWith ", " (map show l) ^ "]" + + fun multilineListToString (show : string -> 'a -> string) (indent : string) (l : 'a list) = + case l of + [] => "[]" + | [x] => "[ " ^ show (indent ^ " ") x ^ " ]" + | (x :: xs) => + let val indent' = indent ^ " " + in "[ " ^ show indent' x ^ concat (map (fn x => "\n" ^ indent ^ ", " ^ show indent' x) xs) ^ "\n" ^ indent ^ "]" + end + + fun quote (s : string) : string = "\"" ^ String.toString s ^ "\"" + + fun optionToString (show : 'a -> string) (x : 'a option) = + case x of + NONE => "NONE" + | SOME x => "SOME " ^ show x + + fun etypeToString (x : etype) : string = + case x of + Tyvar s => "Tyvar " ^ quote s + | Tycon (args, con) => "Tycon (" ^ listToString etypeToString args ^ ", " ^ quote con ^ ")" + | TyTuple args => "TyTuple " ^ listToString etypeToString args + | Tyfun (a, b) => "Tyfun (" ^ etypeToString a ^ ", " ^ etypeToString b ^ ")" + + fun patToString (p : pat) : string = + case p of + PWild => "PWild" + | PVar v => "PVar " ^ quote v + | PInt i => "PInt " ^ Int.toString i + | PTuple pats => "PTuple " ^ listToString patToString pats + | PCon (con, v) => "PCon " ^ "(" ^ listToString quote con ^ ", " ^ patToString v ^ ")" + + fun exprToStringI (indent : string) (x : expr) : string = + let val self = exprToStringI indent + in case x of + EIdent i => "EIdent " ^ listToString quote i + | EBuiltin b => "EBuiltin " ^ quote b + | EInt i => "EInt " ^ Int.toString i + | EStr s => "EStr " ^ quote s + | ETuple xs => "ETuple " ^ listToString self xs + | EList l => "EList " ^ listToString self l + | EApp (f, x) => "EApp (" ^ self f ^ ", " ^ self x ^ ")" + | ETyped (e, t) => "ETyped (" ^ self e ^ ", " ^ etypeToString t ^ ")" + | EAndAlso (a, b) => "EAndAlso (" ^ self a ^ ", " ^ self b ^ ")" + | 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 (p, e) => "DVal (" ^ patToString p ^ ", " ^ exprToStringI indent e ^ ")" + | DValRec (p, e) => "DValRec (" ^ patToString p ^ ", " ^ exprToStringI indent e ^ ")" + | DFun (name, cases) => "DFun (" ^ quote name ^ ", " ^ multilineListToString (fn indent => fn (ps, b) => "(" ^ listToString patToString ps ^ ", " ^ exprToStringI indent b ^ ")") indent cases ^ ")" + | DDatatype (name, arms) => "DDatatype (" ^ quote name ^ ", " ^ listToString (fn (con, v) => "(" ^ quote con ^ ", " ^ optionToString etypeToString v ^ ")") arms ^ ")" + | DStruct (name, decls) => "DStruct (" ^ quote name ^ ",\n" ^ indent ^ "\t" ^ multilineListToString decToStringI (indent ^ "\t") decls ^ ")" + + val exprToString : expr -> string = exprToStringI "" + + val decToString : dec -> string = decToStringI "" + + fun primopToString (x : primop) : string = + case x of + PExit => "PExit" + | PAdd => "PAdd" + | PSub => "PSub" + | PMul => "PMul" + | PDiv => "PDiv" + | PLess => "PLess" + | PEq => "PEq" + | PIf => "PIf" + | PRead => "PRead" + | PWrite => "PWrite" + | PWriteErr => "PWriteErr" + + fun lexpToStringI (indent : string) (x : lexp) : string = + case x of + LVar v => "LVar " ^ Int.toString v + | LFn (arg, expr) => "LFun (" ^ Int.toString arg ^ ",\n" ^ indent ^ "\t" ^ lexpToStringI (indent ^ "\t") expr ^ ")" + | LFix (decls, body) => "LFix (" ^ multilineListToString (fn indent => fn (arg, var, expr) => "(" ^ Int.toString arg ^ ", " ^ Int.toString var ^ ", " ^ lexpToStringI indent expr ^ ")") indent decls ^ ",\n" ^ indent ^ lexpToStringI indent body ^ ")" + | LApp (a, b) => "LApp (" ^ lexpToStringI indent a ^ ",\n" ^ indent ^ "\t" ^ lexpToStringI (indent ^ "\t") b ^ ")" + | LInt i => "LInt " ^ Int.toString i + | LString s => "LString " ^ quote s + | LRecord l => "LRecord " ^ listToString (lexpToStringI indent) l + | LSelect (i, r) => "LSelect (" ^ Int.toString i ^ ", " ^ lexpToStringI indent r ^ ")" + | LPrim p => "LPrim " ^ primopToString p + | LSwitch (e, arms, otherwise) => "LSwitch (" ^ lexpToStringI indent e ^ ",\n" ^ indent ^ "\t" ^ multilineListToString (fn indent => fn (x, e) => "(" ^ Int.toString x ^ ", " ^ lexpToStringI indent e ^ ")") (indent ^ "\t") arms ^ ",\n" ^ indent ^ "\t" ^ optionToString (lexpToStringI (indent ^ "\t")) otherwise ^ ")" + + fun lexpToString (x : lexp) : string = lexpToStringI "" x + + fun valueToString (x : value) : string = + case x of + VVar v => "VVar " ^ Int.toString v + | VLabel l => "VLabel " ^ Int.toString l + | VInt i => "VInt " ^ Int.toString i + + fun cexpToStringI (indent : string) (x : cexp) : string = + let + val self = cexpToStringI indent + val newIndent = indent ^ "\t" + in case x of + CRecord (records, c) => "CRecord (" ^ listToString (fn (a, b) => listToString (fn (x, y) => "(" ^ valueToString x ^ ", " ^ listToString Int.toString y ^ ")") a ^ ", " ^ Int.toString b ^ ")") records ^ ",\n" ^ indent ^ self c ^ ")" + | CSelect (a, b, c, d) => "CSelect (" ^ Int.toString a ^ ", " ^ valueToString b ^ ", " ^ Int.toString c ^ ",\n" ^ indent ^ self d ^ ")" + | CApp (a, b) => "CApp (" ^ valueToString a ^ ", " ^ listToString valueToString b ^ ")" + | CFix (a, b) => "CFix (" ^ multilineListToString (fn indent' => fn (x, y, z) => "(" ^ Int.toString x ^ ", " ^ listToString Int.toString y ^ ",\n" ^ indent' ^ "\t" ^ cexpToStringI (indent' ^ "\t") z) newIndent a ^ ",\n" ^ newIndent ^ cexpToStringI newIndent b ^ ")" + | CPrimop (a, b, c, d) => "CPrimop (" ^ primopToString a ^ ", " ^ listToString valueToString b ^ ", " ^ listToString Int.toString c ^ ",\n" ^ indent ^ multilineListToString cexpToStringI indent d ^ ")" + end + + val cexpToString : cexp -> string = cexpToStringI "" + + fun opcodeToString (oper : opcode) : string = + case oper of + OAlloc (r, s) => "Var " ^ Int.toString r ^ " = OAlloc (" ^ valueToString s ^ ")" + | OCall => "OCall" + | 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 ^ ")" + | OAdd (r, v1, v2) => "Var " ^ Int.toString r ^ " = OAdd (" ^ valueToString v1 ^ ", " ^ valueToString v2 ^ ")" + | OSub (r, v1, v2) => "Var " ^ Int.toString r ^ " = OSub (" ^ valueToString v1 ^ ", " ^ valueToString v2 ^ ")" + | OMul (r, v1, v2) => "Var " ^ Int.toString r ^ " = OMul (" ^ valueToString v1 ^ ", " ^ valueToString v2 ^ ")" + | ODiv (r, v1, v2) => "Var " ^ Int.toString r ^ " = ODiv (" ^ valueToString v1 ^ ", " ^ valueToString v2 ^ ")" + | OLess (r, v1, v2) => "Var " ^ Int.toString r ^ " = OLess (" ^ valueToString v1 ^ ", " ^ valueToString v2 ^ ")" + | OEq (r, v1, v2) => "Var " ^ Int.toString r ^ " = OEq (" ^ valueToString v1 ^ ", " ^ valueToString v2 ^ ")" + | OIf (condition, target) => "OIf (" ^ valueToString condition ^ ") goto " ^ Int.toString target + | OLabel l => "OLabel " ^ Int.toString l + | ORead (r, ptr, off, len) => "Var " ^ Int.toString r ^ " = ORead (Var " ^ Int.toString ptr ^ ", " ^ valueToString off ^ ", " ^ valueToString len ^ ")" + | OWrite (ptr, off, len) => "OWrite (Var " ^ Int.toString ptr ^ ", " ^ valueToString off ^ ", " ^ valueToString len ^ ")" + | OWriteErr (ptr, off, len) => "OWriteErr (Var " ^ Int.toString ptr ^ ", " ^ valueToString off ^ ", " ^ valueToString len ^ ")" +end diff --git a/buffer.sml b/buffer.sml deleted file mode 100644 index 054f29c..0000000 --- a/buffer.sml +++ /dev/null @@ -1,50 +0,0 @@ -structure Buffer = -struct - fun append (a : Word8ArraySlice.slice) (b : Word8ArraySlice.slice) : Word8ArraySlice.slice = - let - val bLen = Word8ArraySlice.length b - val (base, i, aLen) = Word8ArraySlice.base a - val baseLen = Word8Array.length base - in - if i + aLen + bLen <= baseLen - then - (Word8ArraySlice.copy { src = b, dst = base, di = i + aLen } ; - Word8ArraySlice.slice (base, i, SOME (aLen + bLen))) - else - let val newBuf = Word8Array.array (baseLen * 2 + bLen, Word8.fromInt 0) - in - Word8ArraySlice.copy { src = a, dst = newBuf, di = 0 } ; - Word8ArraySlice.copy { src = b, dst = newBuf, di = aLen } ; - Word8ArraySlice.slice (newBuf, 0, SOME (aLen + bLen)) - end - end - - fun buf () : BinIO.outstream * Word8ArraySlice.slice ref = - let val buffer = ref (Word8ArraySlice.full (Word8Array.array (0, Word8.fromInt 0))) - in - (BinIO.mkOutstream - (BinIO.StreamIO.mkOutstream - (BinPrimIO.WR - { name = "buffer" - , chunkSize = 1 - , writeVec = NONE - , writeArr = - SOME - (fn a => - (buffer := append (!buffer) a ; - Word8ArraySlice.length a)) - , writeVecNB = NONE - , writeArrNB = NONE - , block = NONE - , canOutput = NONE - , getPos = NONE - , setPos = NONE - , endPos = NONE - , verifyPos = NONE - , close = fn () => () - , ioDesc = NONE - }, - IO.NO_BUF)), - buffer) - end -end diff --git a/codegen.sml b/codegen.sml deleted file mode 100644 index 0bd86be..0000000 --- a/codegen.sml +++ /dev/null @@ -1,181 +0,0 @@ -structure CodeGen = -struct - fun enumerate l = ListPair.zip (List.tabulate (length l, (fn x => x)), l) - - (* There are 256 registers *) - val tempReg = 255 - - structure VarMap = Map (type k = Syntax.var - val cmp = Int.compare) - - fun cycle (outputs : Syntax.var VarMap.map) (output : Syntax.var) : Syntax.opcode list = - case VarMap.lookup output outputs of - NONE => Syntax.OShuf (output, Syntax.VVar tempReg) :: cycles outputs - | SOME input => - Syntax.OShuf (output, Syntax.VVar input) :: cycle (VarMap.delete output outputs) input - - and cycles (outputs : Syntax.var VarMap.map) : Syntax.opcode list = - case VarMap.lookupMin outputs of - NONE => [] - | SOME (output, input) => - Syntax.OShuf (tempReg, Syntax.VVar input) :: cycle (VarMap.delete output outputs) input - - fun shuffle' (inputs : unit VarMap.map) (outputs : Syntax.var VarMap.map) : Syntax.opcode list = - case VarMap.lookupMin (VarMap.difference outputs inputs) of - NONE => cycles outputs - | SOME (output, input) => - Syntax.OShuf (output, Syntax.VVar input) :: shuffle' (VarMap.delete input inputs) (VarMap.delete output outputs) - - fun shuffle (args : Syntax.value list) : Syntax.opcode list = - let - val outputMap = - VarMap.fromList - (List.mapPartial - (fn (i, Syntax.VVar v) => - if i = v - then NONE - else SOME (i, v) - | _ => NONE) - (enumerate args)) - val inputMap = - VarMap.fromList - (map - (fn (_, input) => (input, ())) - (VarMap.toList outputMap)) - val constants = - List.mapPartial - (fn (_, Syntax.VVar _) => NONE - | (i, constArg) => SOME (Syntax.OShuf (i, constArg))) - (enumerate args) - in - shuffle' inputMap outputMap @ constants - end - - fun buildVarMap (first : int) (expr : Syntax.cexp) : Syntax.var VarMap.map = - let - val next = ref first - fun insert v m = - let val this = !next - in - next := this + 1; - VarMap.insert v this m - end - fun go expr = - case expr of - Syntax.CRecord (records, k) => - foldl - (fn ((_, res), acc) => insert res acc) - (go k) - records - | Syntax.CSelect (_, _, res, k) => insert res (go k) - | Syntax.CApp _ => VarMap.empty - | Syntax.CFix (funcs, body) => - let - val funcsVars = - foldl - (fn ((_, args, body), acc) => - let - val argsVars = - foldl - (fn ((i, arg), acc) => VarMap.insert arg i acc) - VarMap.empty - (ListPair.zip - (List.tabulate (length args, fn x => x + 1), - args)) - val bodyVars = buildVarMap (length args + 1) body - in VarMap.union (VarMap.union acc argsVars) bodyVars - end) - VarMap.empty - funcs - val bodyVars = go body - in VarMap.union funcsVars bodyVars - end - | Syntax.CPrimop (_, _, res, k) => - let - val resVars = - foldl - (fn (v, acc) => insert v acc) - VarMap.empty - res - val kVars = - foldl - (fn (expr, acc) => VarMap.union acc (go expr)) - VarMap.empty - k - in - VarMap.union resVars kVars - end - in go expr - end - - fun toASM (expr : Syntax.cexp) : Syntax.opcode list = - let - val varMap = buildVarMap 0 expr - fun translate v = - case VarMap.lookup v varMap of - NONE => raise Fail ("unable to translate var " ^ Int.toString v) - | SOME x => x - fun translateVal (Syntax.VVar v) = Syntax.VVar (translate v) - | translateVal x = x - fun go expr = - case expr of - Syntax.CRecord (records, k) => - map (fn (args, res) => Syntax.OAlloc (translate res, Syntax.VInt (length args))) - records - @ List.concat - (map - (fn (args, res) => - List.concat - (map - (fn (i, (arg, path)) => - let val (temp, ops) = - foldl - (fn (off, (arg, ops)) => - (Syntax.VVar tempReg, Syntax.OPeek (tempReg, off, arg) :: ops)) - (translateVal arg, []) - path - in rev (Syntax.OPoke (i, translate res, temp) :: ops) - end) - (enumerate args))) - records) - @ go k - | Syntax.CSelect (i, arg, res, k) => Syntax.OPeek (translate res, i, translateVal arg) :: go k - | Syntax.CApp (func, args) => shuffle (map translateVal (func :: args)) @ [Syntax.OCall] - | Syntax.CFix (funcs, body) => - let - val bodyASM = go body - val funcsASM = - foldl - (fn ((name, _, body), acc) => - Syntax.OLabel name :: go body @ acc) - [] - funcs - in - bodyASM @ funcsASM - end - | Syntax.CPrimop (Syntax.PExit, [arg], _, _) => [Syntax.OExit (translateVal arg)] - | Syntax.CPrimop (Syntax.PAdd, [x, y], [res], [k]) => Syntax.OAdd (translate res, translateVal x, translateVal y) :: go k - | Syntax.CPrimop (Syntax.PSub, [x, y], [res], [k]) => Syntax.OSub (translate res, translateVal x, translateVal y) :: go k - | Syntax.CPrimop (Syntax.PMul, [x, y], [res], [k]) => Syntax.OMul (translate res, translateVal x, translateVal y) :: go k - | Syntax.CPrimop (Syntax.PDiv, [x, y], [res], [k]) => Syntax.ODiv (translate res, translateVal x, translateVal y) :: go k - | Syntax.CPrimop (Syntax.PLess, [x, y], [res], [k]) => Syntax.OLess (translate res, translateVal x, translateVal y) :: go k - | Syntax.CPrimop (Syntax.PEq, [x, y], [res], [k]) => Syntax.OEq (translate res, translateVal x, translateVal y) :: go k - | Syntax.CPrimop (Syntax.PIf, [b], [], [k1, k2]) => - let - val trueLabel = GenSym.new () - in - Syntax.OIf (translateVal b, trueLabel) - :: go k2 - @ Syntax.OLabel trueLabel - :: go k1 - end - | Syntax.CPrimop (Syntax.PRead, [Syntax.VVar ptr, off, len], [res], [k]) => - Syntax.ORead (translate res, translate ptr, translateVal off, translateVal len) :: go k - | Syntax.CPrimop (Syntax.PWrite, [Syntax.VVar ptr, off, len], _, [k]) => - Syntax.OWrite (translate ptr, translateVal off, translateVal len) :: go k - | Syntax.CPrimop (Syntax.PWriteErr, [Syntax.VVar ptr, off, len], _, [k]) => - Syntax.OWriteErr (translate ptr, translateVal off, translateVal len) :: go k - | _ => raise Fail ("malformed CPS:\n" ^ Syntax.cexpToString expr) - in go expr - end -end diff --git a/compiler.sml b/compiler.sml deleted file mode 100644 index 4c5e238..0000000 --- a/compiler.sml +++ /dev/null @@ -1,40 +0,0 @@ -structure Compiler = -struct - fun compile (prog : Syntax.expr) : Word8Vector.vector = - let - val _ = print ("ast:\n" ^ Syntax.exprToString prog ^ "\n") - val elab = Elab.elaborate prog - val _ = print ("lambda lang:\n" ^ Syntax.lexpToString elab ^ "\n") - val cps = - CPS.toCPS elab - (fn _ => Syntax.CPrimop (Syntax.PExit, [Syntax.VInt 0], [], [])) - val _ = print ("cps1:\n" ^ Syntax.cexpToString cps ^ "\n") - val cps' = CPS.convertClosures cps - val _ = print ("cps:\n" ^ Syntax.cexpToString cps' ^ "\n") - val asm = CodeGen.toASM cps' - val _ = print ("bytecode:\n" ^ String.concatWith "\n" (map Syntax.opcodeToString asm) ^ "\n") - in - Linker.link asm - end - - fun main (args : string list) : unit = - let - val opts = { o = ref "a.out" } - val flags = - [ ("o", Opts.StringOpt (fn arg => #o opts := arg)) ] - val filename = - case Opts.getOpt flags args of - [arg] => arg - | _ => raise Fail "usage: sml [-o ] " - val ast = - case Parser.parse filename of - Result.Left e => - (print e ; - OS.Process.exit OS.Process.failure) - | Result.Right x => x - val bytecode = compile ast - val outFile = BinIO.openOut (!(#o opts)) - in - BinIO.output (outFile, bytecode) - end -end diff --git a/cps.sml b/cps.sml deleted file mode 100644 index 13dbbe8..0000000 --- a/cps.sml +++ /dev/null @@ -1,271 +0,0 @@ -structure CPS = -struct - fun toCPS (e : Syntax.lexp) (cont : Syntax.value -> Syntax.cexp) : Syntax.cexp = - case e of - Syntax.LVar v => cont (Syntax.VVar v) - | Syntax.LFn (v, expr) => - let - val fnName = GenSym.new () - val k = GenSym.new () - in - Syntax.CFix - ([(fnName, [v, k], toCPS expr (fn ret => Syntax.CApp (Syntax.VVar k, [ret])))], - cont (Syntax.VVar fnName)) - end - | Syntax.LFix (decls, body) => - Syntax.CFix - ( map - (fn (name, arg, expr) => - let val w = GenSym.new () - in - ( name - , [arg, w] - , toCPS expr (fn z => Syntax.CApp (Syntax.VVar w, [z])) - ) - end) - decls - , toCPS body cont - ) - | Syntax.LApp (Syntax.LPrim primop, Syntax.LRecord args) => - let - val temp = GenSym.new () - fun go [] acc = Syntax.CPrimop (primop, rev acc, [temp], [cont (Syntax.VVar temp)]) - | go (arg :: args) acc = toCPS arg (fn arg' => go args (arg' :: acc)) - in go args [] - end - | Syntax.LApp (Syntax.LPrim primop, arg) => toCPS (Syntax.LApp (Syntax.LPrim primop, Syntax.LRecord [arg])) cont - | Syntax.LApp (f, x) => - let - val addr = GenSym.new () - val arg = GenSym.new () - in Syntax.CFix - ([(addr, [arg], cont (Syntax.VVar arg))], - toCPS f (fn f' => - toCPS x (fn x' => - Syntax.CApp (f', [x', Syntax.VVar addr])))) - end - | Syntax.LInt i => cont (Syntax.VInt i) - | Syntax.LString s => - let val temp = GenSym.new () - in - Syntax.CRecord - ( [(map (fn c => (Syntax.VInt (Char.ord c), [])) (String.explode s), temp)] - , cont (Syntax.VVar temp) - ) - end - | Syntax.LRecord [] => cont (Syntax.VInt 0) - | Syntax.LSelect (i, expr) => - let val temp = GenSym.new () - in toCPS expr (fn x => Syntax.CSelect (i, x, temp, cont (Syntax.VVar temp))) - end - | Syntax.LRecord exprs => - let - fun go [] vars = - let val temp = GenSym.new () - in Syntax.CRecord ([(map (fn v => (v, [])) (rev vars), temp)], cont (Syntax.VVar temp)) - end - | go (expr :: exprs) vars = - toCPS expr (fn v => go exprs (v :: vars)) - in go exprs [] - end - | Syntax.LSwitch (expr, arms, otherwise) => - let - val sortedArms = Sort.sort (fn ((x, _), (y, _)) => Int.compare (x, y)) arms - val contAddr = GenSym.new () - val otherwiseAddr = GenSym.new () - val arg = GenSym.new () - fun go _ [] cont = Syntax.CApp (Syntax.VVar otherwiseAddr, []) - | go v [(x, arm)] cont = - (case otherwise of - NONE => toCPS arm cont - | SOME _ => - let val b = GenSym.new () - in - Syntax.CPrimop - ( Syntax.PEq - , [v, Syntax.VInt x] - , [b] - , [ Syntax.CPrimop - ( Syntax.PIf - , [Syntax.VVar b] - , [] - , [toCPS arm cont, Syntax.CApp (Syntax.VVar otherwiseAddr, [])] - ) - ] - ) - end) - | go v arms cont = - let - val b = GenSym.new () - val h = length arms div 2 - val half1 = List.take (arms, h) - val half2 = List.drop (arms, h) - val (x, _) = hd half2 - in - Syntax.CPrimop - ( Syntax.PLess - , [v, Syntax.VInt x] - , [b] - , [ Syntax.CPrimop - ( Syntax.PIf - , [Syntax.VVar b] - , [] - , [go v half1 cont, go v half2 cont] - ) - ] - ) - end - fun contFunc x = Syntax.CApp (Syntax.VVar contAddr, [x]) - val fixFuncs = [(contAddr, [arg], cont (Syntax.VVar arg))] - val fixFuncs = - case otherwise of - NONE => fixFuncs - | SOME otherwise => (otherwiseAddr, [], toCPS otherwise contFunc) :: fixFuncs - in - Syntax.CFix - ( fixFuncs - , toCPS expr (fn v => go v sortedArms contFunc) - ) - end - | _ => raise Fail ("malformed expression " ^ Syntax.lexpToString e) - - fun hoist (expr : Syntax.cexp) : Syntax.cexp = - let - fun exprs (Syntax.CRecord (records, k)) = Syntax.CRecord (records, 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, [])) - end - - structure VarMap = Map (type k = Syntax.var - val cmp = Int.compare) - - fun varSet (l : Syntax.var list) : unit VarMap.map = VarMap.fromList (map (fn x => (x, ())) l) - - fun freeVars (expr : Syntax.cexp) : unit VarMap.map = - case expr of - Syntax.CRecord (records, k) => - let - val kFreeVars = freeVars k - val argFreeVars = - foldl - (fn ((args, _), acc) => - VarMap.union acc (varSet (List.mapPartial (fn (Syntax.VVar v, _) => SOME v | _ => NONE) args))) - VarMap.empty - records - val results = - foldl - (fn ((_, res), acc) => - VarMap.insert res () acc) - VarMap.empty - records - in - VarMap.difference (VarMap.union kFreeVars argFreeVars) results - end - | Syntax.CSelect (_, arg, res, k) => - let - val argFreeVars = - case arg of - Syntax.VVar v => varSet [v] - | _ => VarMap.empty - val kFreeVars = VarMap.delete res (freeVars k) - in - VarMap.union argFreeVars kFreeVars - end - | Syntax.CApp (func, args) => - let - val funcFreeVars = - case func of - Syntax.VVar v => varSet [v] - | _ => VarMap.empty - val argFreeVars = varSet (List.mapPartial (fn Syntax.VVar v => SOME v | _ => NONE) args) - in - VarMap.union funcFreeVars argFreeVars - end - | Syntax.CFix (funs, body) => - let - val names = varSet (map (fn (name, _, _) => name) funs) - val funsFreeVars = map (fn (name, args, fixBody) => VarMap.difference (freeVars fixBody) (varSet args)) funs - val bodyFreeVars = freeVars body - in - foldl (fn (x, acc) => VarMap.union acc (VarMap.difference x names)) VarMap.empty (bodyFreeVars :: funsFreeVars) - end - | Syntax.CPrimop (_, args, res, ks) => - let - val argFreeVars = varSet (List.mapPartial (fn Syntax.VVar v => SOME v | _ => NONE) args) - val boundVars = varSet res - val kFreeVars = foldl (fn (x, acc) => VarMap.union acc x) VarMap.empty (map (fn k => VarMap.difference (freeVars k) boundVars) ks) - in - VarMap.union argFreeVars kFreeVars - end - - fun freeVarsClosure (name, args, body) = map (fn (x, _) => x) (VarMap.toList (VarMap.difference (freeVars body) (varSet args))) - - fun enumerate l = ListPair.zip (List.tabulate (length l, (fn x => x)), l) - - fun convertExpr varMap expr = - let - fun translate var = getOpt (VarMap.lookup var varMap, var) - fun translateValue (Syntax.VVar v) = Syntax.VVar (translate v) - | translateValue v = v - in - case expr of - Syntax.CRecord (records, k) => - Syntax.CRecord (map (fn (args, res) => (map (fn (v, p) => (translateValue v, p)) args, res)) records, convertExpr varMap k) - | Syntax.CSelect (i, arg, res, k) => - Syntax.CSelect (i, translateValue arg, res, convertExpr varMap k) - | Syntax.CApp (func, args) => - let - val temp = GenSym.new () - val f = translateValue func - in Syntax.CSelect (0, f, temp, - Syntax.CApp (Syntax.VVar temp, f :: map translateValue args)) - end - | Syntax.CFix (funcs, body) => - let - val convertedFuncs = - map - (fn this as (name, args, body) => - let - val funcFreeVars = freeVarsClosure this - val varMap' = VarMap.union varMap (VarMap.fromList (map (fn v => (v, GenSym.new ())) funcFreeVars)) - val closure = GenSym.new () - val newBody = - foldl - (fn ((i, x), acc) => Syntax.CSelect (i + 1, Syntax.VVar closure, valOf (VarMap.lookup x varMap'), acc)) - (convertExpr varMap' body) - (enumerate funcFreeVars) - in - (GenSym.new (), closure :: args, newBody) - end) - funcs - val newBody = - Syntax.CRecord - ( map - (fn (old as (oldName, args, body), (newName, _, _)) => - let val funcFreeVars = freeVarsClosure old - in ((Syntax.VLabel newName, []) :: map (fn v => (Syntax.VVar (translate v), [])) funcFreeVars, oldName) - end) - (ListPair.zip (funcs, convertedFuncs)) - , convertExpr varMap body - ) - in - Syntax.CFix (convertedFuncs, newBody) - end - | Syntax.CPrimop (p, args, res, ks) => - Syntax.CPrimop (p, map translateValue args, res, map (convertExpr varMap) ks) - end - - fun convertClosures (expr : Syntax.cexp) : Syntax.cexp = hoist (convertExpr VarMap.empty expr) -end diff --git a/elab.sml b/elab.sml deleted file mode 100644 index 60760cd..0000000 --- a/elab.sml +++ /dev/null @@ -1,419 +0,0 @@ -structure Elab = -struct - structure StringMap = Map(type k = string val cmp = String.compare) - structure IntMap = Map(type k = int val cmp = Int.compare) - - fun primop (s : string) : Syntax.primop = - case s of - "exit" => Syntax.PExit - | "add" => Syntax.PAdd - | "sub" => Syntax.PSub - | "mul" => Syntax.PMul - | "div" => Syntax.PDiv - | "read" => Syntax.PRead - | "write" => Syntax.PWrite - | "writeErr" => Syntax.PWriteErr - | _ => raise Fail ("invalid op: " ^ s) - - fun enumerate (l : 'a list) : (int * 'a) list = - let - fun go _ [] = [] - | go i (x :: xs) = (i, x) :: go (i + 1) xs - in go 0 l - end - - fun hdstls ([] : 'a list list) : ('a list * 'a list list) option = SOME ([], []) - | hdstls ([] :: _) = NONE - | hdstls ((x :: xs) :: ls) = - case hdstls ls of - NONE => NONE - | SOME (heads, tails) => SOME (x :: heads, xs :: tails) - - fun transpose ([] : 'a list list) : 'a list list = [] - | transpose l = - case hdstls l of - NONE => [] - | SOME (heads, tails) => heads :: transpose tails - - datatype env = Env of { vars: int StringMap.map, types: (int * int) StringMap.map, structTypes: env StringMap.map } - - val emptyEnv = Env { vars = StringMap.empty, types = StringMap.empty, structTypes = StringMap.empty } - - fun bindVar (name : string) (sym : int) (Env env) : env = Env { vars = StringMap.insert name sym (#vars env), types = #types env, structTypes = #structTypes env } - - fun lookupVar (name : string) (Env env) : int = - case StringMap.lookup name (#vars env) of - SOME x => x - | NONE => raise Fail ("unbound identifier " ^ name) - - fun bindDataCons (cons : (string * Syntax.etype option) list) (Env env) : env = - let - val nCons = length cons - val (_, vars, types) = - foldl - (fn ((name, _), (i, vars, types)) => - (i + 1, StringMap.insert name (GenSym.new ()) vars, StringMap.insert name (i, nCons) types)) - (0, #vars env, #types env) - cons - in Env { vars = vars, types = types, structTypes = #structTypes env } - end - - fun lookupStructType (name : string) (Env env) : env = - case StringMap.lookup name (#structTypes env) of - SOME x => x - | NONE => raise Fail ("unbound structure " ^ name) - - fun lookupCon ([name] : string list) (Env env) : int option = - Option.map (fn (i, _) => i) (StringMap.lookup name (#types env)) - | lookupCon (structName :: names) env = - lookupCon names (lookupStructType structName env) - | lookupCon [] _ = raise Fail "lookupCon empty" - - fun nConstructors ([name] : string list) (Env env) : int = - let val (_, n) = valOf (StringMap.lookup name (#types env)) - in n - end - | nConstructors (structName :: names) env = - nConstructors names (lookupStructType structName env) - | nConstructors [] _ = raise Fail "nConstructors empty" - - fun patternMatrix (arms : Syntax.pat list) : Syntax.pat list list = - let val ts = - foldl - (fn (Syntax.PWild, tupleSize) => tupleSize - | (Syntax.PVar _, tupleSize) => tupleSize - | (Syntax.PCon _, _) => ~2 - | (Syntax.PInt _, _) => ~2 - | (Syntax.PTuple t, ~1) => length t - | (Syntax.PTuple t, tupleSize) => - if tupleSize = length t - then tupleSize - else raise Fail "a type checker would have caught this") - ~1 - arms - in if ts < 0 - then [arms] - else let - val expandedArms = - map - (fn Syntax.PTuple t => t - | _ => List.tabulate (ts, fn _ => Syntax.PWild)) - arms - val cols = transpose expandedArms - in List.concat (map patternMatrix cols) - end - end - - fun occurrenceVector (expr : Syntax.lexp) (arms : Syntax.pat list) : Syntax.lexp list = - let - val expandedArms = - List.mapPartial - (fn Syntax.PTuple t => SOME t - | _ => NONE) - arms - val cols = transpose expandedArms - in - case cols of - [] => [expr] - | _ => List.concat (map (fn (i, col) => occurrenceVector (Syntax.LSelect (i, expr)) col) (enumerate cols)) - end - - fun patternBindings (expr : Syntax.lexp) (Syntax.PVar v) : (string * Syntax.lexp) list = [(v, expr)] - | patternBindings expr (Syntax.PTuple t) = - List.concat (map (fn (i, p) => patternBindings (Syntax.LSelect (i, expr)) p) (enumerate t)) - | patternBindings expr (Syntax.PCon (_, arg)) = patternBindings (Syntax.LSelect (1, expr)) arg - | patternBindings _ _ = [] - - fun swap1 0 (l : 'a list) : 'a list = l - | swap1 n (first :: rest) = - (case swap1 (n - 1) rest of - x :: rest => x :: first :: rest - | _ => raise Fail "swap1: index out of bounds") - | swap1 _ _ = raise Fail "swap1: index out of bounds" - - fun swap (n : int) (patterns : Syntax.pat list list) (occurrences : Syntax.lexp list) : Syntax.pat list list * Syntax.lexp list = - (map (swap1 n) patterns, swap1 n occurrences) - - fun specialize (env : env) (n : int) (patterns : Syntax.pat list list, occurrences : Syntax.lexp list, actions : Syntax.lexp list) : Syntax.pat list list * Syntax.lexp list * Syntax.lexp list = - let - val con1 = - List.find - (fn Syntax.PCon (name, _) => valOf (lookupCon name env) = n - | _ => false) - (map hd patterns) - val newTupleSize = - case con1 of - SOME (Syntax.PCon (_, Syntax.PTuple t)) => length t - | _ => 0 - val occHead = hd occurrences - val occRest = tl occurrences - val occurrences = - if newTupleSize = 0 - then Syntax.LSelect (1, occHead) :: occRest - else - List.tabulate (newTupleSize, fn i => Syntax.LSelect (i, Syntax.LSelect (1, occHead))) @ occRest - fun specializeRow (Syntax.PInt i :: rest) = - if i = n then SOME (Syntax.PWild :: rest) else NONE - | specializeRow (Syntax.PWild :: rest) = SOME (Syntax.PWild :: rest) - | specializeRow (Syntax.PVar _ :: rest) = SOME (Syntax.PWild :: rest) - | specializeRow (Syntax.PCon (con, Syntax.PTuple []) :: rest) = - specializeRow (Syntax.PCon (con, Syntax.PTuple [Syntax.PWild]) :: rest) - | specializeRow (Syntax.PCon (con, Syntax.PTuple args) :: rest) = - if valOf (lookupCon con env) = n - then SOME (args @ rest) - else NONE - | specializeRow (Syntax.PCon (con, obj) :: rest) = - specializeRow (Syntax.PCon (con, Syntax.PTuple [obj]) :: rest) - | specializeRow _ = raise Fail "unexpected pattern in the matrix" - val (patterns, actions) = - ListPair.unzip - (List.mapPartial - (fn (p, a) => - Option.map (fn p => (p, a)) (specializeRow p)) - (ListPair.zipEq (patterns, actions))) - in (patterns, occurrences, actions) - end - - fun default (patterns : Syntax.pat list list, occurrences : Syntax.lexp list, actions : Syntax.lexp list) : Syntax.pat list list * Syntax.lexp list * Syntax.lexp list = - let - val (patterns, actions) = - ListPair.unzip - (List.filter - (fn (Syntax.PWild :: _, _) => true - | (Syntax.PVar _ :: _, _) => true - | _ => false) - (ListPair.zipEq (patterns, actions))) - in (patterns, occurrences, actions) - end - - fun compilePatternMatching (env : env) ([] : Syntax.pat list list, _ : Syntax.lexp list, _ : Syntax.lexp list) : Syntax.lexp = - raise Fail "nonexhaustive match" - | compilePatternMatching env (patterns as firstRow :: rows, occurrences, actions) = - let val refutablePattern = - List.find - (fn (_, Syntax.PInt _) => true - | (_, Syntax.PCon _) => true - | _ => false) - (enumerate firstRow) - in - case refutablePattern of - NONE => hd actions - | SOME (i, _) => - let - val (patterns, occurrences) = - if i = 0 - then (patterns, occurrences) - else swap i patterns occurrences - val firstCol = map hd patterns - val signatures = - map (fn (x, _) => x) - (IntMap.toList - (foldl - (fn (Syntax.PInt i, acc) => IntMap.insert i true acc - | (Syntax.PCon (c, _), acc) => IntMap.insert (valOf (lookupCon c env)) true acc - | (_, acc) => acc) - IntMap.empty - firstCol)) - val nCons = - case List.find (fn (Syntax.PCon _) => true | _ => false) firstCol of - SOME (Syntax.PCon (name, _)) => nConstructors name env - | _ => ~1 - val defaultCase = - if length signatures = nCons - then NONE - else SOME (compilePatternMatching env (default (patterns, occurrences, actions))) - val switchOperand = - if nCons < 0 - then hd occurrences - else Syntax.LSelect (0, hd occurrences) - in - Syntax.LSwitch - ( switchOperand - , map - (fn i => (i, compilePatternMatching env (specialize env i (patterns, occurrences, actions)))) - signatures - , defaultCase - ) - end - end - - fun declBoundVars (Syntax.DVal (p, _)) : string list = map (fn (x, _) => x) (patternBindings (Syntax.LInt 0) p) - | declBoundVars (Syntax.DValRec (p, _)) = map (fn (x, _) => x) (patternBindings (Syntax.LInt 0) p) - | declBoundVars (Syntax.DFun (name, _)) = [name] - | declBoundVars (Syntax.DDatatype (_, cons)) = map (fn (x, _) => x) cons - | declBoundVars (Syntax.DStruct (name, _)) = [name] - - fun structBoundVars (decls : Syntax.dec list) : string list = List.concatMap declBoundVars decls - - fun bindStructType (name : string) (decls : Syntax.dec list) (Env env) : env = - let - val structEnv = - foldl - (fn (Syntax.DDatatype (_, cons), env) => bindDataCons cons env - | (Syntax.DStruct (name, decls), env) => bindStructType name decls env - | (_, env) => env) - emptyEnv - decls - val structEnv = - foldl - (fn ((i, n), env) => bindVar n i env) - structEnv - (enumerate (structBoundVars decls)) - in - Env { vars = #vars env, types = #types env, structTypes = StringMap.insert name structEnv (#structTypes env) } - end - - fun actionVector (env : env) (expr : Syntax.lexp) (arms : (Syntax.pat * Syntax.expr) list) : Syntax.lexp list = - map - (fn (p, body) => - let - val bindings = patternBindings expr p - val env = - foldl - (fn ((name, _), env) => - bindVar name (GenSym.new ()) env) - env - bindings - in - foldl - (fn ((name, binding), acc) => - Syntax.LApp (Syntax.LFn (lookupVar name env, acc), binding)) - (elab env body) - bindings - end) - arms - - and elabCase (env : env) (expr : Syntax.lexp) (arms : (Syntax.pat * Syntax.expr) list) = - let - val patterns = transpose (patternMatrix (map (fn (x, _) => x) arms)) - val occurrences = occurrenceVector expr (map (fn (x, _) => x) arms) - val actions = actionVector env expr arms - val actionFns = - map - (fn a => (GenSym.new (), GenSym.new (), a)) - actions - val smallActions = - map - (fn (f, _, _) => Syntax.LApp (Syntax.LVar f, Syntax.LInt 0)) - actionFns - in - Syntax.LFix - ( actionFns - , compilePatternMatching env (patterns, occurrences, smallActions) - ) - end - - and elab (env : env) (p : Syntax.expr) : Syntax.lexp = - case p of - Syntax.EIdent [i] => Syntax.LVar (lookupVar i env) - | Syntax.EIdent (structName :: accessors) => - let - val s = Syntax.LVar (lookupVar structName env) - val env = lookupStructType structName env - fun go env [i] acc = Syntax.LSelect (lookupVar i env, acc) - | go env (accessor :: accessors) acc = - let val env = lookupStructType accessor env - in go env accessors (Syntax.LSelect (lookupVar accessor env, acc)) - end - | go _ [] _ = raise Fail "go empty" - in go env accessors s - end - | Syntax.EIdent [] => raise Fail "invalid syntax" - | Syntax.EBuiltin builtin => Syntax.LPrim (primop builtin) - | Syntax.EInt i => Syntax.LInt i - | Syntax.EStr s => Syntax.LString s - | Syntax.ETuple exprs => Syntax.LRecord (map (elab env) exprs) - | Syntax.EList exprs => - foldr - (fn (x, acc) => - Syntax.LRecord [elab env x, acc]) - (Syntax.LInt 0) - exprs - | Syntax.EApp (f, x) => Syntax.LApp (elab env f, elab env x) - | Syntax.ETyped (e, _) => elab env e - | Syntax.EAndAlso (_, _) => raise Fail "unimplemented" - | Syntax.EOrElse (_, _) => raise Fail "unimplemented" - | Syntax.ELet ([], body) => elab env body - | Syntax.ELet (Syntax.DDatatype (name, cons) :: decls, body) => - let - val env = bindDataCons cons env - val funs = - List.mapPartial - (fn (_, (_, NONE)) => NONE - | (i, (name, _)) => - let val v = GenSym.new () - in SOME (lookupVar name env, v, Syntax.LRecord [Syntax.LInt i, Syntax.LVar v]) - end) - (enumerate cons) - val vals = - List.mapPartial - (fn (i, (name, NONE)) => SOME (lookupVar name env, Syntax.LRecord [Syntax.LInt i]) - | _ => NONE) - (enumerate cons) - in - foldl - (fn ((v, x), acc) => - Syntax.LApp (Syntax.LFn (v, acc), x)) - (Syntax.LFix (funs, elab env (Syntax.ELet (decls, body)))) - vals - end - | Syntax.ELet (Syntax.DVal (pat, v) :: decls, body) => - elab env (Syntax.ECase (v, [(pat, Syntax.ELet (decls, body))])) - | Syntax.ELet (Syntax.DValRec (Syntax.PVar name, f as Syntax.ELambda _) :: decls, body) => - let - val n = GenSym.new () - val env = bindVar name n env - val (arg, fnBody) = - case elab env f of - Syntax.LFn x => x - | _ => raise Fail "Syntax.ELambda should expand to Syntax.LFn" - in - Syntax.LFix ([(n, arg, fnBody)], elab env (Syntax.ELet (decls, body))) - end - | Syntax.ELet (Syntax.DValRec _ :: _, _) => raise Fail "invalid val rec" - | Syntax.ELet (Syntax.DFun (name, cases) :: decls, body) => - let - val (ps1, _) = hd cases - val nPats = length ps1 - in if not (List.all (fn (ps, _) => length ps = nPats) cases) - then raise Fail "clauses do not all have same number of patterns" - else let - val n = GenSym.new () - val temps = List.tabulate (nPats, fn _ => GenSym.new ()) - val env = bindVar name n env - val t = GenSym.new () - val innerCase = elabCase env (Syntax.LVar t) (map (fn (ps, b) => (Syntax.PTuple ps, b)) cases) - in - Syntax.LFix - ( [ ( n - , hd temps - , foldr - Syntax.LFn - (Syntax.LApp (Syntax.LFn (t, innerCase), Syntax.LRecord (map Syntax.LVar temps))) - (tl temps) - ) - ] - , elab env (Syntax.ELet (decls, body)) - ) - end - end - | Syntax.ELet (Syntax.DStruct (name, structDecls) :: decls, body) => - let - val names = structBoundVars structDecls - val tuple = elab env (Syntax.ELet (structDecls, Syntax.ETuple (map (fn n => Syntax.EIdent [n]) names))) - val v = GenSym.new () - val env = bindStructType name structDecls env - val env = bindVar name v env - in Syntax.LApp (Syntax.LFn (v, elab env (Syntax.ELet (decls, body))), tuple) - end - | Syntax.ELambda body => - let val v = GenSym.new () - in Syntax.LFn (v, elabCase env (Syntax.LVar v) [body]) - end - | Syntax.ECase (expr, arms) => - let val v = GenSym.new () - in Syntax.LApp (Syntax.LFn (v, elabCase env (Syntax.LVar v) arms), elab env expr) - end - - fun elaborate (p : Syntax.expr) : Syntax.lexp = elab emptyEnv p -end diff --git a/gensym.sml b/gensym.sml deleted file mode 100644 index eef7333..0000000 --- a/gensym.sml +++ /dev/null @@ -1,5 +0,0 @@ -structure GenSym = -struct - val counter : int ref = ref 0 - fun new () : int = (counter := (!counter + 1) ; !counter) -end diff --git a/linker.sml b/linker.sml deleted file mode 100644 index 684451d..0000000 --- a/linker.sml +++ /dev/null @@ -1,149 +0,0 @@ -structure Linker = -struct - fun makeOpcode w code arg1Const arg2Const = - if code >= 0x40 - then raise Fail "code is more than 6 bits" - else - let - val arg1Bit = if arg1Const then 2 else 0 - val arg2Bit = if arg2Const then 1 else 0 - in - BinIO.output1 (w, Word8.fromInt (code * 4 + arg1Bit + arg2Bit)) - end - - fun isConst (Syntax.VVar _) = false - | isConst _ = true - - fun lowByte w n = - BinIO.output1 (w, Word8.fromInt (Word.toInt (Word.andb (n, Word.fromInt 0xff)))) - - fun writeInt w i = - let val n = Word.fromInt i - in - (lowByte w (Word.orb (Word.<< (n, Word.fromInt 1), Word.fromInt 0x1)) ; - lowByte w (Word.>> (n, Word.fromInt 7)) ; - lowByte w (Word.>> (n, Word.fromInt 15)) ; - lowByte w (Word.>> (n, Word.fromInt 23)) ; - lowByte w (Word.>> (n, Word.fromInt 31)) ; - lowByte w (Word.>> (n, Word.fromInt 39)) ; - lowByte w (Word.>> (n, Word.fromInt 47)) ; - lowByte w (Word.>> (n, Word.fromInt 55))) - end - - fun writeVar w v = - if v > CodeGen.tempReg - then raise Fail ("var out of range: " ^ Int.toString v) - else lowByte w (Word.fromInt v) - - fun writeOffset w i = - if i < 0 - then raise Fail ("negative offset: " ^ Int.toString i) - else writeInt w i - - structure IntMap = Map(type k = int val cmp = Int.compare) - - fun encode (m : int IntMap.map) (w : BinIO.outstream) (oper : Syntax.opcode) : unit = - let - fun writeValue w (Syntax.VVar v) = writeVar w v - | writeValue w (Syntax.VLabel l) = writeInt w (getOpt (IntMap.lookup l m, 0)) - | writeValue w (Syntax.VInt i) = writeInt w i - in - case oper of - Syntax.OAlloc (r, v) => - (makeOpcode w 1 (isConst v) false ; - writeVar w r ; - writeValue w v) - | Syntax.OCall => - makeOpcode w 2 false false - | Syntax.OPoke (off, p, v) => - (makeOpcode w 3 (isConst v) false ; - writeOffset w off ; - writeVar w p ; - writeValue w v) - | Syntax.OPeek (r, off, v) => - (makeOpcode w 4 (isConst v) false ; - writeVar w r ; - writeOffset w off ; - writeValue w v) - | Syntax.OShuf (r, v) => - (makeOpcode w 5 (isConst v) false ; - writeVar w r ; - writeValue w v) - | Syntax.OExit v => - (makeOpcode w 6 (isConst v) false ; - writeValue w v) - | Syntax.OAdd (r, v1, v2) => - (makeOpcode w 7 (isConst v1) (isConst v2) ; - writeVar w r ; - writeValue w v1 ; - writeValue w v2) - | Syntax.OSub (r, v1, v2) => - (makeOpcode w 8 (isConst v1) (isConst v2) ; - writeVar w r ; - writeValue w v1 ; - writeValue w v2) - | Syntax.OMul (r, v1, v2) => - (makeOpcode w 9 (isConst v1) (isConst v2) ; - writeVar w r ; - writeValue w v1 ; - writeValue w v2) - | Syntax.ODiv (r, v1, v2) => - (makeOpcode w 10 (isConst v1) (isConst v2) ; - writeVar w r ; - writeValue w v1 ; - writeValue w v2) - | Syntax.OLess (r, v1, v2) => - (makeOpcode w 11 (isConst v1) (isConst v2) ; - writeVar w r ; - writeValue w v1 ; - writeValue w v2) - | Syntax.OEq (r, v1, v2) => - (makeOpcode w 12 (isConst v1) (isConst v2) ; - writeVar w r ; - writeValue w v1 ; - writeValue w v2) - | Syntax.OIf (condition, label) => - (makeOpcode w 13 (isConst condition) false ; - writeValue w condition ; - writeValue w (Syntax.VLabel label)) - | Syntax.OLabel _ => () - | Syntax.ORead (r, ptr, off, len) => - (makeOpcode w 14 (isConst off) (isConst len) ; - writeVar w r ; - writeVar w ptr ; - writeValue w off ; - writeValue w len) - | Syntax.OWrite (ptr, off, len) => - (makeOpcode w 15 (isConst off) (isConst len) ; - writeVar w ptr ; - writeValue w off ; - writeValue w len) - | Syntax.OWriteErr (ptr, off, len) => - (makeOpcode w 16 (isConst off) (isConst len) ; - writeVar w ptr ; - writeValue w off ; - writeValue w len) - end - - fun link (program : Syntax.opcode list) : Word8Vector.vector = - let - val (w1, b1) = Buffer.buf () - val labels = - foldl - (fn (x, acc) => - (encode IntMap.empty w1 x ; - case x of - Syntax.OLabel l => IntMap.insert l (Word8ArraySlice.length (!b1)) acc - | _ => acc)) - IntMap.empty - program - val (w, b) = Buffer.buf () - fun go [] = () - | go (oper :: program) = - (encode labels w oper ; - go program) - in - go program ; - Word8ArraySlice.vector (!b) - end -end diff --git a/main.sml b/main.sml index 762fd76..b391219 100644 --- a/main.sml +++ b/main.sml @@ -1,17 +1,16 @@ -use "sort.sml"; -use "result.sml"; -use "buffer.sml"; -use "gensym.sml"; -use "map.sml"; -use "syntax.sml"; -use "codegen.sml"; -use "cps.sml"; -use "elab.sml"; -use "gensym.sml"; -use "linker.sml"; -use "opts.sml"; -use "parser.sml"; -use "compiler.sml"; +use "Sort.sml"; +use "Result.sml"; +use "Buffer.sml"; +use "GenSym.sml"; +use "Map.sml"; +use "Syntax.sml"; +use "CodeGen.sml"; +use "CPS.sml"; +use "Elab.sml"; +use "Linker.sml"; +use "Opts.sml"; +use "Parser.sml"; +use "Compiler.sml"; val _ = Compiler.main (CommandLine.arguments ()) val _ = OS.Process.exit OS.Process.success diff --git a/map.sml b/map.sml deleted file mode 100644 index d8b3a37..0000000 --- a/map.sml +++ /dev/null @@ -1,186 +0,0 @@ -(* 🅱️-tree *) -signature MAP = -sig - type key - type 'a map - - val empty : 'a map - val null : 'a map -> bool - val insert : key -> 'a -> 'a map -> 'a map - val lookup : key -> 'a map -> 'a option - val delete : key -> 'a map -> 'a map - val union : 'a map -> 'a map -> 'a map - val intersect : 'a map -> 'a map -> 'a map - val difference : 'a map -> 'b map -> 'a map - val fromList : (key * 'a) list -> 'a map - val toList : 'a map -> (key * 'a) list - val lookupMin : 'a map -> (key * 'a) option -end - -functor Map (type k - val cmp : k * k -> order) :> MAP where type key = k = -struct - type key = k - - datatype 'a map = - Tip - | Two of int * 'a map * key * 'a * 'a map - | Three of int * 'a map * key * 'a * 'a map * key * 'a * 'a map - - val empty : 'a map = Tip - - fun null Tip = true - | null _ = false - - fun height (Tip : 'a map) : int = 0 - | height (Two (h, _, _, _, _)) = h - | height (Three (h, _, _, _, _, _, _, _)) = h - - fun two (l : 'a map) (k : key) (v : 'a) (r : 'a map) : 'a map = - if height l <> height r then raise Fail "two: height mismatch" else - Two (height l + 1, l, k, v, r) - - fun three (a : 'a map) (k1 : key) (v1 : 'a) (b : 'a map) (k2 : key) (v2 : 'a) (c : 'a map) : 'a map = - if not (height a = height b andalso height b = height c) then raise Fail "three: height mismatch" else - Three (height a + 1, a, k1, v1, b, k2, v2, c) - - fun view (Tip : 'a map) : ('a map * key * 'a * 'a map) option = NONE - | view (Two (_, l, k, v, r)) = SOME (l, k, v, r) - | view (Three (h, a, k1, v1, b, k2, v2, c)) = SOME (a, k1, v1, two b k2 v2 c) - - fun lookup (k : key) (m : 'a map) : 'a option = - case view m of - NONE => NONE - | SOME (l, k', v, r) => - case cmp (k, k') of - EQUAL => SOME v - | LESS => lookup k l - | GREATER => lookup k r - - datatype 'a insertResult = - One of 'a map - | Split of 'a map * key * 'a * 'a map - - fun join' (left : 'a map) (k : key) (v : 'a) (right : 'a map) : 'a insertResult = - if height left = height right then - Split (left, k, v, right) - else if height left < height right then - case right of - Tip => raise Fail "unreachable" - | Two (_, rl, rk, rv, rr) => - (case join' left k v rl of - One newNode => One (two newNode rk rv rr) - | Split (left, k, v, right) => One (three left k v right rk rv rr)) - | Three (_, ra, rk1, rv1, rb, rk2, rv2, rc) => - case join' left k v ra of - One newNode => One (three newNode rk1 rv1 rb rk2 rv2 rc) - | Split (left, k, v, right) => Split (two left k v right, rk1, rv1, two rb rk2 rv2 rc) - else - case left of - Tip => raise Fail "unreachable" - | Two (_, ll, lk, lv, lr) => - (case join' lr k v right of - One newNode => One (two ll lk lv newNode) - | Split (left, k, v, right) => One (three ll lk lv left k v right)) - | Three (_, la, lk1, lv1, lb, lk2, lv2, lc) => - case join' lc k v right of - One newNode => One (three la lk1 lv1 lb lk2 lv2 newNode) - | Split (left, k, v, right) => Split (two la lk1 lv1 lb, lk2, lv2, two left k v right) - - fun join (left : 'a map) (k : key) (v : 'a) (right : 'a map) : 'a map = - case join' left k v right of - One node => node - | Split (left, k, v, right) => two left k v right - - fun split (m : 'a map) (k : key) : 'a map * bool * 'a map = - case view m of - NONE => (Tip, false, Tip) - | SOME (l, k', v, r) => - case cmp (k, k') of - EQUAL => (l, true, r) - | LESS => - let val (ll, found, lr) = split l k - in (ll, found, join lr k' v r) - end - | GREATER => - let val (rl, found, rr) = split r k - in (join l k' v rl, found, rr) - end - - fun splitLast (m : 'a map) : 'a map * (key * 'a) = - case view m of - SOME (l, k, v, Tip) => (l, (k, v)) - | SOME (l, k, v, r) => - let val (t', k') = splitLast r - in (join l k v t', k') - end - | NONE => raise Fail "splitLast Tip" - - fun join2 (Tip : 'a map) (tr : 'a map) : 'a map = tr - | join2 tl tr = - let val (tl', (kx, x)) = splitLast tl - in join tl' kx x tr - end - - fun delete (k : key) (m : 'a map) : 'a map = - let val (tl, _, tr) = split m k - in join2 tl tr - end - - fun union (Tip : 'a map) (t2 : 'a map) : 'a map = t2 - | union t1 t2 = - case view t2 of - NONE => t1 - | SOME (l2, k2, v2, r2) => - let - val (l1, _, r1) = split t1 k2 - val tl = union l1 l2 - val tr = union r1 r2 - in join tl k2 v2 tr - end - - fun intersect (Tip : 'a map) (_ : 'a map) : 'a map = Tip - | intersect t1 t2 = - case view t2 of - NONE => Tip - | SOME (l2, k2, v2, r2) => - let - val (l1, b, r1) = split t1 k2 - val tl = intersect l1 l2 - val tr = intersect r1 r2 - in - if b then join tl k2 v2 tr - else join2 tl tr - end - - fun difference (Tip : 'a map) (_ : 'b map) : 'a map = Tip - | difference t1 t2 = - case view t2 of - NONE => t1 - | SOME (l2, k2, _, r2) => - let - val (l1, _, r1) = split t1 k2 - val tl = difference l1 l2 - val tr = difference r1 r2 - in join2 tl tr - end - - fun singleton (k : key) (v : 'a) : 'a map = two Tip k v Tip - - fun insert (k : key) (v : 'a) (m : 'a map) : 'a map = union m (singleton k v) - - fun fromList (l : (key * 'a) list) : 'a map = foldl (fn ((kx, x), acc) => insert kx x acc) empty l - - fun toList' (m : 'a map) (acc : (key * 'a) list) : (key * 'a) list = - case view m of - NONE => acc - | SOME (l, k, v, r) => toList' l ((k, v) :: toList' r acc) - - fun toList (m : 'a map) : (key * 'a) list = toList' m [] - - fun lookupMin (m : 'a map) : (key * 'a) option = - case view m of - NONE => NONE - | SOME (Tip, k, v, _) => SOME (k, v) - | SOME (l, _, _, _) => lookupMin l -end diff --git a/opts.sml b/opts.sml deleted file mode 100644 index f5be8c4..0000000 --- a/opts.sml +++ /dev/null @@ -1,81 +0,0 @@ -structure Opts = -struct - datatype 'a optDesc = BoolOpt of bool -> unit - | StringOpt of string -> unit - - structure StringMap = Map(type k = string val cmp = String.compare) - - fun error (msg : string) : 'a = - (print msg ; - OS.Process.exit (OS.Process.failure)) - - fun boolFromString s = - case s of - "1" => true - | "t" => true - | "T" => true - | "true" => true - | "TRUE" => true - | "True" => true - | "0" => false - | "f" => false - | "F" => false - | "false" => false - | "FALSE" => false - | "False" => false - | _ => error "invalid boolean value" - - fun getOpt (desc : (string * 'a optDesc) list) (args : string list) : string list = - let - val parsers = StringMap.fromList desc - fun go [] = [] - | go (arg :: args) = - if arg = "-" orelse not (String.isPrefix "-" arg) - then arg :: args - else if arg = "--" - then args - else - let - val name = - if String.isPrefix "--" arg - then String.extract (arg, 2, NONE) - else String.extract (arg, 1, NONE) - val _ = - if String.isPrefix "-" name orelse String.isPrefix "=" name - then error "bad flag syntax" - else () - (* It's a flag. Does it have an argument? *) - val (name', value) = - case CharVector.findi (fn (_, x) => x = #"=") name of - SOME (i, _) => (substring (name, 0, i), String.extract (name, i + 1, NONE)) - | NONE => (name, "") - val parser = - case StringMap.lookup name' parsers of - SOME x => x - | NONE => error ("flag provided but not defined: " ^ String.toString name') - in - case parser of - BoolOpt func => - if value = "" - then - (func true ; - go args) - else - (func (boolFromString value) ; - go args) - | StringOpt func => - (* It must have a value, which might be the next argument. *) - if value = "" andalso not (null args) - then - (func (hd args) ; - go (tl args)) - else if value = "" - then error ("flag needs an argument: " ^ String.toString name') - else - (func value ; - go args) - end - in - go args - end -end diff --git a/parser.sml b/parser.sml deleted file mode 100644 index e464332..0000000 --- a/parser.sml +++ /dev/null @@ -1,672 +0,0 @@ -infix 4 <$> <$ -infix 1 >> -infixr 1 <|> -infix 0 - -structure Parser = -struct - structure StringMap = Map(type k = string val cmp = String.compare) - - (* vector of length 10, holding the left and right associative infix operators for each precedence level. *) - type infixTable = (string list * string list) vector - type userState = {infixTable : infixTable} - type sourceLoc = {file : string, row : int, column : int} - type state = {stream : TextIO.StreamIO.instream, loc : sourceLoc, userState : userState} - datatype response = Consumed | Empty - datatype message = Unexpected of string | Expected of string - type parseError = {loc : sourceLoc, msgs : message list} - datatype hints = Hints of string list - type 'a parser = state -> response * (parseError, 'a * state * hints) Result.either - - val reservedWords = - [ "abstype", "and", "andalso", "as", "case", "datatype", "do", "else" - , "end", "exception", "fn", "fun", "handle", "if", "in", "infix" - , "infixr", "let", "local", "nonfix", "of", "op", "open", "orelse" - , "raise", "rec", "then", "type", "val", "with", "withtype", "while" - , "(", ")", "[", "]", "{", "}", ",", ":", ";", "...", "_", "|", "=", "=>", "->", "#" - , "eqtype", "functor", "include", "sharing", "sig" - , "signature", "struct", "structure", "where", ":>" - ] - - val emptyInfixOperators : infixTable = - Vector.tabulate (10, fn _ => ([], [])) - - fun printSourceLoc ({file, row, column} : sourceLoc) : string = - file ^ ":" ^ Int.toString row ^ "." ^ Int.toString column - - fun printError ({loc, msgs} : parseError) : string = - let - val unexpect = List.mapPartial (fn Unexpected x => SOME x | _ => NONE) msgs - val showUnexpect = case unexpect of - [] => "" - | s :: _ => "unexpected " ^ s ^ ";\n" - val expect = List.mapPartial (fn Expected s => SOME s | _ => NONE) msgs - in - printSourceLoc loc ^ " Syntax error:\n" - ^ showUnexpect - ^ "expecting " ^ String.concatWith ", " expect - end - - fun unpackParserResponse (_ : response, Result.Left err : (parseError, 'a * state * hints) Result.either) : (string, 'a) Result.either = - Result.Left (printError err) - | unpackParserResponse (_, Result.Right (a, st, _)) = - if TextIO.StreamIO.endOfStream (#stream st) - then Result.Right a - else Result.Left (printSourceLoc (#loc st) ^ " Syntax error: trailing characters") - - fun newLoc (fileName : string) : sourceLoc = { - file = fileName, - row = 1, - column = 1 - } - - fun collectInfixOperators (opTable : (string list * string list) vector) : string list = - Vector.foldl (fn ((a, b), acc) => a @ b @ acc) [] opTable - - fun infixOps (opTable : infixTable) : string list = - Vector.foldl (fn ((a, b), acc) => a @ b @ acc) [] opTable - - fun newState (fileName : string) (fileStream : TextIO.instream) : state = { - stream = TextIO.getInstream fileStream, - loc = newLoc fileName, - userState = {infixTable = emptyInfixOperators} - } - - fun updateUserState (f : userState -> userState) : userState parser = - fn {stream, loc, userState} => - let val st' = f userState - in (Empty, Result.Right (st', {stream = stream, loc = loc, userState = st'}, Hints [])) - end - - val getUserState : userState parser = updateUserState (fn x => x) - - fun runParser (p : 'a parser) (fileName : string) : (string, 'a) Result.either = - unpackParserResponse (p (newState fileName (TextIO.openIn fileName))) - - fun testParser (p : 'a parser) (s : string) : 'a = - case unpackParserResponse (p (newState "STRING" (TextIO.openString s))) of - Result.Right x => x - | Result.Left e => raise Fail ("Parse failed: " ^ e) - - fun mergeHints (Hints a) (Hints b) : hints = Hints (a @ b) - - fun withHints (Hints hints) ({loc, msgs} : parseError) : parseError = { - loc = loc, - msgs = map Expected hints @ msgs - } - - fun errToHints ({msgs, ...} : parseError) : hints = Hints (List.mapPartial (fn Expected s => SOME s | _ => NONE) msgs) - - fun compareLoc (l : sourceLoc, m : sourceLoc) : order = - case Int.compare (#row l, #row m) of - EQUAL => Int.compare (#column l, #column m) - | ord => ord - - fun mergeError (e1 : parseError) (e2 : parseError) : parseError = - (* pick the longest match *) - case compareLoc (#loc e1, #loc e2) of - EQUAL => { - loc = #loc e1, - msgs = #msgs e1 @ #msgs e2 - } - | GREATER => e1 - | LESS => e2 - - fun bind (p : 'a parser) (f : 'a -> 'b parser) : 'b parser = - fn st => - case p st of - (consumed1, Result.Right (a, st', hints)) => - (case (f a) st' of - (Consumed, Result.Right success) => (Consumed, Result.Right success) - | (Empty, Result.Right (b, st'', hints')) => (consumed1, Result.Right (b, st'', mergeHints hints hints')) - | (Consumed, Result.Left err) => (Consumed, Result.Left (withHints hints err)) - | (Empty, Result.Left err) => (consumed1, Result.Left (withHints hints err))) - | (consumed, Result.Left err) => (consumed, Result.Left err) - - fun (p1 : 'a parser) >> (p2 : 'b parser) : 'b parser = bind p1 (fn _ => p2) - - fun (p : 'a parser) (msg : string) : 'a parser = - fn st => - case p st of - (consumed, Result.Right (a, st', _)) => (consumed, Result.Right (a, st', Hints [msg])) - | (consumed, Result.Left {loc, ...}) => (consumed, Result.Left {loc = loc, msgs = [Expected msg]}) - - fun (p1 : 'a parser) <|> (p2 : 'a parser) : 'a parser = - fn st => - case p1 st of - (Empty, Result.Left err) => - (case p2 st of - (Empty, Result.Right (a, st', hints)) => (Empty, Result.Right (a, st', mergeHints (errToHints err) hints)) - | (Empty, Result.Left err') => (Empty, Result.Left (mergeError err err')) - | res => res) - | res => res - - fun const (x : 'a) (st : state) = (Empty, Result.Right (x, st, Hints [])) - - fun (f : 'a -> 'b) <$> (p : 'a parser) : 'b parser = bind p (const o f) - - fun (x : 'a) <$ (p : 'b parser) : 'a parser = (fn _ => x) <$> p - - fun try (p : 'a parser) : 'a parser = - fn st => - case p st of - (Consumed, Result.Left err) => (Empty, Result.Left err) - | res => res - - fun updatePosChar ({file, row, column} : sourceLoc) (c : char) : sourceLoc = - case c of - #"\n" => { - file = file, - row = row + 1, - column = 1 - } - | #"\t" => { - file = file, - row = row, - column = column + 8 - (column - 1) mod 8 - } - | _ => { - file = file, - row = row, - column = column + 1 - } - - fun satisfy (pred : char -> bool) : char parser = - fn {stream, loc, userState} => - case TextIO.StreamIO.input1 stream of - NONE => (Empty, Result.Left {loc = loc, msgs = [Expected "UNKNOWN"]}) - | SOME (c, stream') => - if pred c - then (Consumed, Result.Right (c, {stream = stream', loc = updatePosChar loc c, userState = userState}, Hints [])) - else (Empty, Result.Left {loc = loc, msgs = [Expected "UNKNOWN"]}) - - fun parseChar (c : char) : char parser = - satisfy (fn c' => c = c') str c - - fun parseString (s : string) : string parser = - case explode s of - [] => const "" - | c1 :: cs => s <$ foldl (fn (c, p) => p >> parseChar c) (parseChar c1) cs "'" ^ String.toString s ^ "'" - - fun manyErr () = raise Fail "many is applied to a parser that accepts an empty string" - - fun many (p : 'a parser) : 'a list parser = - fn st => - let fun walk xs s' = - case p s' of - (Consumed, Result.Right (x, s'', _)) => walk (x :: xs) s'' - | (Consumed, Result.Left err) => (Consumed, Result.Left err) - | (Empty, Result.Right _) => manyErr () - | (Empty, Result.Left err) => (Consumed, Result.Right (rev xs, s', errToHints err)) - in - case p st of - (Consumed, Result.Right (x, s', _)) => walk [x] s' - | (Consumed, Result.Left err) => (Consumed, Result.Left err) - | (Empty, Result.Right _) => manyErr () - | (Empty, Result.Left err) => (Empty, Result.Right ([], st, errToHints err)) - end - - fun many1 (p : 'a parser) : 'a list parser = - bind p (fn x => - bind (many p) (fn xs => - const (x :: xs))) - - val space : char parser = satisfy Char.isSpace "space" - - val spaces : unit parser = () <$ many space "white space" - - fun unexpected (s : string) : 'a parser = - fn {loc, ...} => (Empty, Result.Left {loc = loc, msgs = [Unexpected s]}) - - val letter : char parser = satisfy Char.isAlpha "letter" - - val alphaNum : char parser = satisfy Char.isAlphaNum "letter or digit" - - fun oneOf ([] : char list) : char parser = raise Fail "oneOf empty" - | oneOf (x :: xs) = foldl (fn (c, p) => p <|> parseChar c) (parseChar x) xs - - (* some day, whiteSpace will support comments *) - val whiteSpace = spaces - - fun lexeme (p : 'a parser) : 'a parser = - bind p (fn x => - whiteSpace >> - const x) - - val alphaNumIdentifierLetter : char parser = - alphaNum <|> oneOf [#"'", #"_"] - - val symbolicIdentifierLetters : char list = - [ #"!", #"%", #"&", #"$", #"#", #"+", #"-", #"/", #":", #"<" - , #"=", #">", #"?", #"@", #"\\", #"~", #"`", #"^", #"|", #"*" - ] - - val symbolicIdentifierLetter : char parser = oneOf symbolicIdentifierLetters - - val alphaNumIdentifier : string parser = - lexeme - (bind letter (fn firstLetter => - bind (many alphaNumIdentifierLetter) (fn rest => - const (implode (firstLetter :: rest))))) - - val tyvar : string parser = - lexeme - (bind (parseChar #"'") (fn firstLetter => - bind (many alphaNumIdentifierLetter) (fn rest => - const (implode (firstLetter :: rest))))) - - val symbolicIdentifier : string parser = - lexeme - (implode <$> many1 symbolicIdentifierLetter) - - fun notReserved (reserved : string list) : string parser = - try - (bind (alphaNumIdentifier <|> symbolicIdentifier "identifier") (fn identName => - if List.exists (fn n => n = identName) reserved - then unexpected identName - else const identName)) - - val identifier : string parser = - bind getUserState (fn {infixTable, ...} => - notReserved (infixOps infixTable @ reservedWords)) - - val tycon : string parser = - bind getUserState (fn st => - notReserved ("*" :: reservedWords)) - - fun sepBy1 (p : 'a parser) (sep : 'b parser) : 'a list parser = - bind p (fn x => - bind (many (sep >> p)) (fn xs => - const (x :: xs))) - - fun sepBy (p : 'a parser) (sep : 'b parser) : 'a list parser = - sepBy1 p sep <|> const [] - - fun symbol (s : string) : string parser = lexeme (parseString s) - - val longIdentifier : string list parser = sepBy1 identifier (symbol ".") - - fun notFollowedBy (p : char parser) : unit parser = - bind (try p) (fn c => unexpected (str c)) - <|> const () - - fun reserved (s : string) : string parser = - let - val start = - if s = "" - then raise Fail "reserved was called on an empty string" - else String.sub (s, 0) - val isSymbolic = - List.exists (fn c => c = start) symbolicIdentifierLetters - in - lexeme - (try - (parseString s >> - notFollowedBy (if isSymbolic then symbolicIdentifierLetter else alphaNumIdentifierLetter) >> - const s)) - s - end - - val infixIdentifier : string parser = - bind getUserState (fn {infixTable, ...} => - let val ops = map reserved (Vector.foldl (fn ((l, r), acc) => l @ r @ acc) [] infixTable) - in - case ops of - [] => unexpected "infix op" - | x :: xs => foldl op <|> x xs "infix op" - end) - - val longInfixIdentifier : string list parser = - bind (many (bind identifier (fn id => symbol "." >> const id))) (fn idents => - bind infixIdentifier (fn ii => - const (idents @ [ii]))) - - val digit : char parser = satisfy Char.isDigit "digit" - - val integer : int parser = - lexeme - (bind (many1 digit) (fn digits => - const (valOf (Int.fromString (implode digits))))) - - val stringInternalChar : char parser = - (parseString "\\" >> (#"\a" <$ parseChar #"a" - <|> #"\b" <$ parseChar #"b" - <|> #"\t" <$ parseChar #"t" - <|> #"\n" <$ parseChar #"n" - <|> #"\v" <$ parseChar #"v" - <|> #"\f" <$ parseChar #"f" - <|> #"\r" <$ parseChar #"r" - <|> parseChar #"\"" - <|> parseChar #"\\") "string escape") - <|> (satisfy (fn c => c <> #"\"" andalso c <> #"\\") "string character") - - val stringConstant : string parser = - lexeme - (parseString "\"" >> - bind (implode <$> many stringInternalChar) (fn stringContent => - parseString "\"" >> - const stringContent)) - - val builtin : Syntax.expr parser = - reserved "__builtin" >> - Syntax.EBuiltin <$> stringConstant - - fun between (left : 'a parser) (right : 'b parser) (p : 'c parser) : 'c parser = - left >> - bind p (fn x => - right >> - const x) - - fun parseTycons (ty : Syntax.etype) : Syntax.etype parser = - bind tycon (fn longtycon => - parseTycons (Syntax.Tycon ([ty], longtycon))) - <|> const ty - - val rec parseSingleType : Syntax.etype parser = fn st => - (Syntax.Tyvar <$> (tyvar <|> tycon) - <|> bind (between (symbol "(") (symbol ")") (sepBy1 parseType (symbol ","))) (fn types => - case types of - [x] => const x - | _ => bind tycon (fn longtycon => - const (Syntax.Tycon (types, longtycon))))) st - and parseTycon : Syntax.etype parser = - fn st => - bind parseSingleType parseTycons st - and parseTupleType : Syntax.etype parser = - fn st => - bind (sepBy1 parseTycon (reserved "*")) (fn types => - const - (case types of - [ty] => ty - | _ => Syntax.TyTuple types)) st - and parseType : Syntax.etype parser = - fn st => - bind parseTupleType (fn ty => - (reserved "->" >> - bind parseType (fn ty' => - const (Syntax.Tyfun (ty, ty')))) - <|> const ty) st - - fun leftOp (i : int) : string parser = - bind getUserState (fn {infixTable, ...} => - let val (leftOps, _) = Vector.sub (infixTable, i) - in - case (map reserved leftOps) of - [] => unexpected "left-associative operator" - | op1 :: ops => (fn x => x) <$> foldl op <|> op1 ops - end) - - fun rightOp (i : int) : string parser = - bind getUserState (fn {infixTable, ...} => - let val (_, rightOps) = Vector.sub (infixTable, i) - in - case (map reserved rightOps) of - [] => unexpected "right-associative operator" - | op1 :: ops => (fn x => x) <$> foldl op <|> op1 ops - end) - - val rec atpat : Syntax.pat parser = fn st => - (Syntax.PWild <$ reserved "_" - <|> Syntax.PInt <$> integer - <|> bind (between (symbol "(") (symbol ")") (sepBy pat (symbol ","))) (fn pats => - const - (case pats of - [p] => p - | _ => Syntax.PTuple pats)) - <|> bind longIdentifier (fn [i] => const (Syntax.PVar i) | is => const (Syntax.PCon (is, Syntax.PTuple [])))) st - and appPat : Syntax.pat parser = fn st => - (bind longIdentifier (fn ident => - bind atpat (fn arg => - const (Syntax.PCon (ident, arg))) - <|> const (case ident of - [i] => Syntax.PVar i - | _ => Syntax.PCon (ident, Syntax.PTuple []))) - <|> atpat) st - and pat : Syntax.pat parser = fn st => - foldl - (fn (i, patLower) => - let - fun patLeft pat1 = - bind (leftOp i) (fn opEx => - bind patLower (fn pat2 => - let val app = Syntax.PCon ([opEx], Syntax.PTuple [pat1, pat2]) - in patLeft app <|> const app - end)) - fun patRight pat1 = - bind (rightOp i) (fn opEx => - bind patLower (fn pat2 => - bind (patRight pat2 <|> const pat2) (fn rest => - const (Syntax.PCon ([opEx], Syntax.PTuple [pat1, rest]))))) - in - bind patLower (fn pat1 => - patLeft pat1 <|> patRight pat1 <|> const pat1) - end) - appPat - (List.tabulate (10, fn i => 9 - i)) st - - val rec atom : Syntax.expr parser = - fn st => - (Syntax.EInt <$> integer - <|> Syntax.EStr <$> stringConstant - <|> Syntax.EIdent <$> longIdentifier - <|> (reserved "op" >> Syntax.EIdent <$> longInfixIdentifier) - <|> builtin - <|> (reserved "let" >> - bind (many dec) (fn decs => - reserved "in" >> - bind expr (fn e => - reserved "end" >> - const (Syntax.ELet (List.mapPartial (fn x => x) decs, e))))) - <|> (symbol "(" >> - bind (sepBy expr (symbol ",")) (fn exprs => - symbol ")" >> - const - (case exprs of - [x] => x - | _ => Syntax.ETuple exprs)))) st - and appExp : Syntax.expr parser = - fn st => - bind atom (fn e0 => - foldl (fn (x, acc) => Syntax.EApp (acc, x)) e0 <$> many atom) st - and infixExp : Syntax.expr parser = - fn st => - foldl - (fn (i, exprLower) => - let - fun exprLeft expr1 = - bind (leftOp i) (fn opEx => - bind exprLower (fn expr2 => - let val app = Syntax.EApp (Syntax.EIdent [opEx], Syntax.ETuple [expr1, expr2]) - in exprLeft app <|> const app - end)) - fun exprRight expr1 = - bind (rightOp i) (fn opEx => - bind exprLower (fn expr2 => - bind (exprRight expr2 <|> const expr2) (fn rest => - const (Syntax.EApp (Syntax.EIdent [opEx], Syntax.ETuple [expr1, rest]))))) - in - bind exprLower (fn expr1 => - exprLeft expr1 <|> exprRight expr1 <|> const expr1) - end) - appExp - (List.tabulate (10, fn i => 9 - i)) st - and typedExp : Syntax.expr parser = - fn st => - bind infixExp (fn e => - (reserved ":" >> - bind parseType (fn ty => - const (Syntax.ETyped (e, ty)))) - <|> const e) st - and andalsoExp : Syntax.expr parser = - fn st => - bind typedExp (fn e1 => - (reserved "andalso" >> - bind andalsoExp (fn e2 => - const (Syntax.EAndAlso (e1, e2)))) - <|> const e1) st - and orelseExpr : Syntax.expr parser = - fn st => - bind andalsoExp (fn e1 => - (reserved "orelse" >> - bind orelseExpr (fn e2 => - const (Syntax.EOrElse (e1, e2)))) - <|> const e1) st - and expr : Syntax.expr parser = fn st => - ((reserved "fn" >> - bind pat (fn p => - reserved "=>" >> - bind expr (fn e => - const (Syntax.ELambda (p, e))))) - <|> (reserved "case" >> - bind expr (fn e => - reserved "of" >> - bind - (sepBy1 - (bind pat (fn p => - reserved "=>" >> - bind expr (fn e => - const (p, e)))) - (reserved "|")) (fn arms => - const (Syntax.ECase (e, arms))))) - <|> orelseExpr) st - and dec : Syntax.dec option parser = fn st => - (bind (false <$ reserved "infix" <|> true <$ reserved "infixr") (fn direction => - bind (integer <|> const 0) (fn level => - bind (many1 identifier) (fn ops => - updateUserState - (fn {infixTable} => - let val (leftOps, rightOps) = Vector.sub (infixTable, level) - in - if direction - then {infixTable = Vector.update (infixTable, level, (leftOps, ops @ rightOps))} - else {infixTable = Vector.update (infixTable, level, (ops @ leftOps, rightOps))} - end) >> - const NONE))) - <|> (reserved "datatype" >> - (between (symbol "(") (symbol ")") (sepBy1 tyvar (symbol ",")) - <|> (fn x => [x]) <$> tyvar - <|> const []) >> - bind identifier (fn name => - reserved "=" >> - bind - (sepBy1 - (bind (infixIdentifier <|> identifier) (fn con => - (reserved "of" >> - bind parseType (fn ty => - const (con, SOME ty))) - <|> const (con, NONE))) - (reserved "|")) (fn cons => - const (SOME (Syntax.DDatatype (name, cons)))))) - <|> (reserved "val" >> - bind (true <$ reserved "rec" <|> const false) (fn isRec => - bind pat (fn p => - reserved "=" >> - bind expr (fn e => - const - (SOME - (if isRec - then Syntax.DValRec (p, e) - else Syntax.DVal (p, e))))))) - <|> (reserved "fun" >> - bind - (sepBy1 - (bind (bind atpat (fn pat1 => - bind infixIdentifier (fn infixOp => - bind atpat (fn pat2 => - const (infixOp, [Syntax.PTuple [pat1, pat2]]))) - <|> (case pat1 of - Syntax.PVar name => - bind (many1 atpat) (fn args => - const (name, args)) - | _ => unexpected "pattern"))) (fn (name, args) => - reserved "=" >> - bind expr (fn body => - const (name, args, body)))) - (reserved "|")) (fn cases => - let val (name, _, _) = hd cases - in - if not (List.all (fn (n, _, _) => n = name) cases) - then raise Fail "clauses do not all have same function name" - else const (SOME (Syntax.DFun (name, map (fn (_, x, y) => (x, y)) cases))) - end))) st - - val rec strdec : Syntax.dec option parser = fn st => - ((reserved "structure" >> - bind identifier (fn strID => - reserved "=" >> - reserved "struct" >> - bind (many strdec) (fn bindings => - reserved "end" >> - const (SOME (Syntax.DStruct (strID, List.mapPartial (fn x => x) bindings)))))) - <|> dec) st - - (* There's ambiguity between pattern variables and constructors that can only - * be resolved by checking for constructors in scope *) - fun fixPatConstructors (constructors : unit StringMap.map) (Syntax.PVar v) : Syntax.pat = - if isSome (StringMap.lookup v constructors) - then Syntax.PCon ([v], Syntax.PTuple []) - else Syntax.PVar v - | fixPatConstructors constructors (Syntax.PTuple pats) = Syntax.PTuple (map (fixPatConstructors constructors) pats) - | fixPatConstructors constructors (Syntax.PCon (con, arg)) = Syntax.PCon (con, fixPatConstructors constructors arg) - | fixPatConstructors _ pat = pat - - fun findConstructors (Syntax.DDatatype (_, cases)) : string list = - List.mapPartial - (fn (constructor, NONE) => SOME constructor - | _ => NONE) - cases - | findConstructors _ = [] - - fun fixDecConstructors (constructors : unit StringMap.map) (Syntax.DVal (pat, body)) : Syntax.dec = - Syntax.DVal (fixPatConstructors constructors pat, fixConstructors constructors body) - | fixDecConstructors constructors (Syntax.DValRec (pat, body)) = - Syntax.DValRec (fixPatConstructors constructors pat, fixConstructors constructors body) - | fixDecConstructors constructors (Syntax.DFun (f, arms)) = - Syntax.DFun (f, map (fn (args, body) => (map (fixPatConstructors constructors) args, fixConstructors constructors body)) arms) - | fixDecConstructors _ (decl as Syntax.DDatatype _) = decl - | fixDecConstructors constructors (Syntax.DStruct (name, decs)) = - let - val constructors = ref constructors - val decs : Syntax.dec list = - map - (fn dec => - (constructors := foldl (fn (x, acc) => StringMap.insert x () acc) (!constructors) (findConstructors dec) ; - fixDecConstructors (!constructors) dec)) - decs - in Syntax.DStruct (name, decs) - end - - and fixConstructors (constructors : unit StringMap.map) (Syntax.ETuple exprs) : Syntax.expr = - Syntax.ETuple (map (fixConstructors constructors) exprs) - | fixConstructors constructors (Syntax.EList exprs) = - Syntax.EList (map (fixConstructors constructors) exprs) - | fixConstructors constructors (Syntax.EApp (func, arg)) = - Syntax.EApp (fixConstructors constructors func, fixConstructors constructors arg) - | fixConstructors constructors (Syntax.ETyped (expr, ty)) = - Syntax.ETyped (fixConstructors constructors expr, ty) - | fixConstructors constructors (Syntax.EAndAlso (e1, e2)) = - Syntax.EAndAlso (fixConstructors constructors e1, fixConstructors constructors e2) - | fixConstructors constructors (Syntax.EOrElse (e1, e2)) = - Syntax.EOrElse (fixConstructors constructors e1, fixConstructors constructors e2) - | fixConstructors constructors (Syntax.ELet (decs, body)) = - let - val constructors = ref constructors - val decs = - map - (fn dec => - (constructors := foldl (fn (x, acc) => StringMap.insert x () acc) (!constructors) (findConstructors dec) ; - fixDecConstructors (!constructors) dec)) - decs - in Syntax.ELet (decs, fixConstructors (!constructors) body) - end - | fixConstructors constructors (Syntax.ELambda (pat, body)) = - Syntax.ELambda (fixPatConstructors constructors pat, fixConstructors constructors body) - | fixConstructors constructors (Syntax.ECase (expr, arms)) = - Syntax.ECase (fixConstructors constructors expr, map (fn (pat, expr) => (fixPatConstructors constructors pat, fixConstructors constructors expr)) arms) - | fixConstructors _ expr = expr - - val program : Syntax.expr parser = - bind (many strdec) (fn decs => - const (fixConstructors StringMap.empty (Syntax.ELet (List.mapPartial (fn x => x) decs, Syntax.EInt 0)))) - fun parse (f : string) : (string, Syntax.expr) Result.either = runParser program f -end diff --git a/program.cm b/program.cm index 4724772..ff015c7 100644 --- a/program.cm +++ b/program.cm @@ -1,16 +1,16 @@ Group is -buffer.sml -codegen.sml -compiler.sml -cps.sml -elab.sml -gensym.sml -linker.sml -map.sml -opts.sml -parser.sml -result.sml -syntax.sml +Buffer.sml +CPS.sml +Codegen.sml +Compiler.sml +Elab.sml +GenSym.sml +Linker.sml +Map.sml +Opts.sml +Parser.sml +Result.sml +Syntax.sml $/basis.cm diff --git a/result.sml b/result.sml deleted file mode 100644 index ff1a9a3..0000000 --- a/result.sml +++ /dev/null @@ -1,4 +0,0 @@ -structure Result = -struct - datatype ('a, 'b) either = Left of 'a | Right of 'b -end diff --git a/run-tests.fish b/run-tests.fish new file mode 100644 index 0000000..22c86d5 --- /dev/null +++ b/run-tests.fish @@ -0,0 +1,24 @@ +#!/usr/bin/env fish + +set d (realpath (status dirname)) + +cd $d/bytecode +cargo build; or return + +cd $d + +if test (count $argv) -gt 0 + set files $d/tests/$argv* +else + set files $d/tests/* +end + +for f in $files + $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/run_tests.fish b/run_tests.fish deleted file mode 100644 index 22c86d5..0000000 --- a/run_tests.fish +++ /dev/null @@ -1,24 +0,0 @@ -#!/usr/bin/env fish - -set d (realpath (status dirname)) - -cd $d/bytecode -cargo build; or return - -cd $d - -if test (count $argv) -gt 0 - set files $d/tests/$argv* -else - set files $d/tests/* -end - -for f in $files - $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/sort.sml b/sort.sml deleted file mode 100644 index d9a70e9..0000000 --- a/sort.sml +++ /dev/null @@ -1,24 +0,0 @@ -signature SORT = -sig - val sort : ('a * 'a -> order) -> 'a list -> 'a list -end - -structure Sort :> SORT = -struct - fun merge (_ : 'a * 'a -> order) ([] : 'a list) (l2 : 'a list) : 'a list = l2 - | merge _ l1 [] = l1 - | merge cmp (xl as x :: xs) (yl as y :: ys) = - (case cmp (x, y) of - GREATER => y :: merge cmp xl ys - | _ => x :: merge cmp xs yl) - - fun sort (_ : 'a * 'a -> order) ([] : 'a list) : 'a list = [] - | sort _ [x] = [x] - | sort cmp l = - let - val n = length l - val half1 = List.take (l, n div 2) - val half2 = List.drop (l, n div 2) - in merge cmp (sort cmp half1) (sort cmp half2) - end -end diff --git a/syntax.sml b/syntax.sml deleted file mode 100644 index 2f7a96e..0000000 --- a/syntax.sml +++ /dev/null @@ -1,231 +0,0 @@ -structure Syntax = -struct - (* SML syntax *) - datatype etype = - Tyvar of string - | Tycon of etype list * string - | TyTuple of etype list - | Tyfun of etype * etype - - datatype pat = - PWild - | PVar of string - | PInt of int - | PTuple of pat list - | PCon of string list * pat - - datatype expr = - EIdent of string list - | EBuiltin of string - | EInt of int - | EStr of string - | ETuple of expr list - | EList of expr list - | EApp of expr * expr - | ETyped of expr * etype - | EAndAlso of expr * expr - | EOrElse of expr * expr - | ELet of dec list * expr - | ELambda of pat * expr - | ECase of expr * (pat * expr) list - - and dec = - DVal of pat * expr - | DValRec of pat * expr - | DFun of string * (pat list * expr) list - | DDatatype of string * (string * etype option) list - | DStruct of string * dec list - - (* Lambda language *) - type var = int - - datatype primop = - PExit - | PAdd - | PSub - | PMul - | PDiv - | PLess - | PEq - | PIf - | PRead - | PWrite - | PWriteErr - - datatype lexp = - LVar of var - | LFn of var * lexp - | LFix of (var * var * lexp) list * lexp - | LApp of lexp * lexp - | LInt of int - | LString of string - | LRecord of lexp list - | LSelect of int * lexp - | LPrim of primop - | LSwitch of lexp * (int * lexp) list * lexp option - - (* CPS *) - datatype value = - VVar of var - | VLabel of var - | VInt of int - - datatype cexp = - CRecord of ((value * int list) list * var) list * cexp - | CSelect of int * value * var * cexp - | CApp of value * value list - | CFix of (var * var list * cexp) list * cexp - | CPrimop of primop * value list * var list * cexp list - - datatype opcode = - OAlloc of var * value - | OCall - | OPoke of int * var * value - | OPeek of var * int * value - | OShuf of var * value - | OExit of value - | OAdd of var * value * value - | OSub of var * value * value - | OMul of var * value * value - | ODiv of var * value * value - | OLess of var * value * value - | OEq of var * value * value - | OIf of value * var - | OLabel of var - | ORead of var * var * value * value - | OWrite of var * value * value - | OWriteErr of var * value * value - - fun listToString (show : 'a -> string) (l : 'a list) = - "[" ^ String.concatWith ", " (map show l) ^ "]" - - fun multilineListToString (show : string -> 'a -> string) (indent : string) (l : 'a list) = - case l of - [] => "[]" - | [x] => "[ " ^ show (indent ^ " ") x ^ " ]" - | (x :: xs) => - let val indent' = indent ^ " " - in "[ " ^ show indent' x ^ concat (map (fn x => "\n" ^ indent ^ ", " ^ show indent' x) xs) ^ "\n" ^ indent ^ "]" - end - - fun quote (s : string) : string = "\"" ^ String.toString s ^ "\"" - - fun optionToString (show : 'a -> string) (x : 'a option) = - case x of - NONE => "NONE" - | SOME x => "SOME " ^ show x - - fun etypeToString (x : etype) : string = - case x of - Tyvar s => "Tyvar " ^ quote s - | Tycon (args, con) => "Tycon (" ^ listToString etypeToString args ^ ", " ^ quote con ^ ")" - | TyTuple args => "TyTuple " ^ listToString etypeToString args - | Tyfun (a, b) => "Tyfun (" ^ etypeToString a ^ ", " ^ etypeToString b ^ ")" - - fun patToString (p : pat) : string = - case p of - PWild => "PWild" - | PVar v => "PVar " ^ quote v - | PInt i => "PInt " ^ Int.toString i - | PTuple pats => "PTuple " ^ listToString patToString pats - | PCon (con, v) => "PCon " ^ "(" ^ listToString quote con ^ ", " ^ patToString v ^ ")" - - fun exprToStringI (indent : string) (x : expr) : string = - let val self = exprToStringI indent - in case x of - EIdent i => "EIdent " ^ listToString quote i - | EBuiltin b => "EBuiltin " ^ quote b - | EInt i => "EInt " ^ Int.toString i - | EStr s => "EStr " ^ quote s - | ETuple xs => "ETuple " ^ listToString self xs - | EList l => "EList " ^ listToString self l - | EApp (f, x) => "EApp (" ^ self f ^ ", " ^ self x ^ ")" - | ETyped (e, t) => "ETyped (" ^ self e ^ ", " ^ etypeToString t ^ ")" - | EAndAlso (a, b) => "EAndAlso (" ^ self a ^ ", " ^ self b ^ ")" - | 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 (p, e) => "DVal (" ^ patToString p ^ ", " ^ exprToStringI indent e ^ ")" - | DValRec (p, e) => "DValRec (" ^ patToString p ^ ", " ^ exprToStringI indent e ^ ")" - | DFun (name, cases) => "DFun (" ^ quote name ^ ", " ^ multilineListToString (fn indent => fn (ps, b) => "(" ^ listToString patToString ps ^ ", " ^ exprToStringI indent b ^ ")") indent cases ^ ")" - | DDatatype (name, arms) => "DDatatype (" ^ quote name ^ ", " ^ listToString (fn (con, v) => "(" ^ quote con ^ ", " ^ optionToString etypeToString v ^ ")") arms ^ ")" - | DStruct (name, decls) => "DStruct (" ^ quote name ^ ",\n" ^ indent ^ "\t" ^ multilineListToString decToStringI (indent ^ "\t") decls ^ ")" - - val exprToString : expr -> string = exprToStringI "" - - val decToString : dec -> string = decToStringI "" - - fun primopToString (x : primop) : string = - case x of - PExit => "PExit" - | PAdd => "PAdd" - | PSub => "PSub" - | PMul => "PMul" - | PDiv => "PDiv" - | PLess => "PLess" - | PEq => "PEq" - | PIf => "PIf" - | PRead => "PRead" - | PWrite => "PWrite" - | PWriteErr => "PWriteErr" - - fun lexpToStringI (indent : string) (x : lexp) : string = - case x of - LVar v => "LVar " ^ Int.toString v - | LFn (arg, expr) => "LFun (" ^ Int.toString arg ^ ",\n" ^ indent ^ "\t" ^ lexpToStringI (indent ^ "\t") expr ^ ")" - | LFix (decls, body) => "LFix (" ^ multilineListToString (fn indent => fn (arg, var, expr) => "(" ^ Int.toString arg ^ ", " ^ Int.toString var ^ ", " ^ lexpToStringI indent expr ^ ")") indent decls ^ ",\n" ^ indent ^ lexpToStringI indent body ^ ")" - | LApp (a, b) => "LApp (" ^ lexpToStringI indent a ^ ",\n" ^ indent ^ "\t" ^ lexpToStringI (indent ^ "\t") b ^ ")" - | LInt i => "LInt " ^ Int.toString i - | LString s => "LString " ^ quote s - | LRecord l => "LRecord " ^ listToString (lexpToStringI indent) l - | LSelect (i, r) => "LSelect (" ^ Int.toString i ^ ", " ^ lexpToStringI indent r ^ ")" - | LPrim p => "LPrim " ^ primopToString p - | LSwitch (e, arms, otherwise) => "LSwitch (" ^ lexpToStringI indent e ^ ",\n" ^ indent ^ "\t" ^ multilineListToString (fn indent => fn (x, e) => "(" ^ Int.toString x ^ ", " ^ lexpToStringI indent e ^ ")") (indent ^ "\t") arms ^ ",\n" ^ indent ^ "\t" ^ optionToString (lexpToStringI (indent ^ "\t")) otherwise ^ ")" - - fun lexpToString (x : lexp) : string = lexpToStringI "" x - - fun valueToString (x : value) : string = - case x of - VVar v => "VVar " ^ Int.toString v - | VLabel l => "VLabel " ^ Int.toString l - | VInt i => "VInt " ^ Int.toString i - - fun cexpToStringI (indent : string) (x : cexp) : string = - let - val self = cexpToStringI indent - val newIndent = indent ^ "\t" - in case x of - CRecord (records, c) => "CRecord (" ^ listToString (fn (a, b) => listToString (fn (x, y) => "(" ^ valueToString x ^ ", " ^ listToString Int.toString y ^ ")") a ^ ", " ^ Int.toString b ^ ")") records ^ ",\n" ^ indent ^ self c ^ ")" - | CSelect (a, b, c, d) => "CSelect (" ^ Int.toString a ^ ", " ^ valueToString b ^ ", " ^ Int.toString c ^ ",\n" ^ indent ^ self d ^ ")" - | CApp (a, b) => "CApp (" ^ valueToString a ^ ", " ^ listToString valueToString b ^ ")" - | CFix (a, b) => "CFix (" ^ multilineListToString (fn indent' => fn (x, y, z) => "(" ^ Int.toString x ^ ", " ^ listToString Int.toString y ^ ",\n" ^ indent' ^ "\t" ^ cexpToStringI (indent' ^ "\t") z) newIndent a ^ ",\n" ^ newIndent ^ cexpToStringI newIndent b ^ ")" - | CPrimop (a, b, c, d) => "CPrimop (" ^ primopToString a ^ ", " ^ listToString valueToString b ^ ", " ^ listToString Int.toString c ^ ",\n" ^ indent ^ multilineListToString cexpToStringI indent d ^ ")" - end - - val cexpToString : cexp -> string = cexpToStringI "" - - fun opcodeToString (oper : opcode) : string = - case oper of - OAlloc (r, s) => "Var " ^ Int.toString r ^ " = OAlloc (" ^ valueToString s ^ ")" - | OCall => "OCall" - | 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 ^ ")" - | OAdd (r, v1, v2) => "Var " ^ Int.toString r ^ " = OAdd (" ^ valueToString v1 ^ ", " ^ valueToString v2 ^ ")" - | OSub (r, v1, v2) => "Var " ^ Int.toString r ^ " = OSub (" ^ valueToString v1 ^ ", " ^ valueToString v2 ^ ")" - | OMul (r, v1, v2) => "Var " ^ Int.toString r ^ " = OMul (" ^ valueToString v1 ^ ", " ^ valueToString v2 ^ ")" - | ODiv (r, v1, v2) => "Var " ^ Int.toString r ^ " = ODiv (" ^ valueToString v1 ^ ", " ^ valueToString v2 ^ ")" - | OLess (r, v1, v2) => "Var " ^ Int.toString r ^ " = OLess (" ^ valueToString v1 ^ ", " ^ valueToString v2 ^ ")" - | OEq (r, v1, v2) => "Var " ^ Int.toString r ^ " = OEq (" ^ valueToString v1 ^ ", " ^ valueToString v2 ^ ")" - | OIf (condition, target) => "OIf (" ^ valueToString condition ^ ") goto " ^ Int.toString target - | OLabel l => "OLabel " ^ Int.toString l - | ORead (r, ptr, off, len) => "Var " ^ Int.toString r ^ " = ORead (Var " ^ Int.toString ptr ^ ", " ^ valueToString off ^ ", " ^ valueToString len ^ ")" - | OWrite (ptr, off, len) => "OWrite (Var " ^ Int.toString ptr ^ ", " ^ valueToString off ^ ", " ^ valueToString len ^ ")" - | OWriteErr (ptr, off, len) => "OWriteErr (Var " ^ Int.toString ptr ^ ", " ^ valueToString off ^ ", " ^ valueToString len ^ ")" -end -- cgit v1.3.1