diff --git a/.github/workflows/check.yml b/.github/workflows/check.yml index 0296f118a..3564fc1ab 100644 --- a/.github/workflows/check.yml +++ b/.github/workflows/check.yml @@ -41,15 +41,15 @@ jobs: else echo ${branch:1:2} > assignment_number.txt fi - - name: Check Deadline - run: | - deadline=2023-12-30T23:59 - if [[ $(date +'%Y-%m-%dT%H:%M') > $deadline ]]; - then - echo "FIASCO: The deadline has expired" - echo $(date +'%Y-%m-%dT%H:%M') - exit 1 - fi + - name: Check Deadline + run: | + deadline=2023-12-30T23:59 + if [[ $(date +'%Y-%m-%dT%H:%M') > $deadline ]]; + then + echo "FIASCO: The deadline has expired" + echo $(date +'%Y-%m-%dT%H:%M') + exit 1 + fi - uses: actions/upload-artifact@v2 with: name: share_info diff --git a/src/Builtins.lama b/src/Builtins.lama index ccb362317..1e3f004f2 100644 --- a/src/Builtins.lama +++ b/src/Builtins.lama @@ -1,14 +1,27 @@ -- Builtins import World; +import Array; + +-- ONLY FOR THIS HOMEWORK +-- The only function that operates on S-Expressions +-- is the `length` function +fun sexpToArray (x) { + case x of + S (tag, arr) -> mapArray (sexpToArray, arr) + | #array -> mapArray (sexpToArray, x) + | x : xs -> sexpToArray (x) : sexpToArray (xs) + | x -> x + esac +} public fun evalBuiltin (name, args, w) { - case [name, args] of - ["stringval", {a}] -> [a.string, w] - | ["length" , {a@#array}] -> [a.length, w] - | ["length" , {a@#str}] -> [a.length, w] - | ["length" , {Sexp (_, vs)}] -> [vs.length, w] - | ["read" , {}] -> readWorld (w) - | ["write" , {x@#val}] -> [0, writeWorld (x, w)] + case [name, sexpToArray (args)] of + ["stringval", {a}] -> [a.string, w] + | ["length" , {a@#array}] -> [a.length, w] + | ["length" , {a@#str}] -> [a.length, w] + | ["length" , {Sexp (_, vals)}] -> [vals.length, w] + | ["read" , {}] -> readWorld (w) + | ["write" , {x@#val}] -> [0, writeWorld (x, w)] | _ -> failure ("no builtin ""%s"" or it can not be applied to %s\n", name, args.string) esac diff --git a/src/Expr.lama b/src/Expr.lama index 193e8b9b5..c9367dfb2 100644 --- a/src/Expr.lama +++ b/src/Expr.lama @@ -55,6 +55,7 @@ public fun evalOp (op, l, r) { -- Ignore (expr) | -- String (string) | -- Array (expr list) | +-- Sexp (string, expr list) | -- Elem (expr, expr) | -- ElemRef (expr, expr) | -- Builtin (string, expr list) @@ -101,8 +102,183 @@ fun evalList (c, exprs) { esac } +fun unwrapVal (x) { + case x of Val (x) -> x esac +} + +fun lookupUnwrapVal (state, name) { + unwrapVal (lookupVal (state, name)) +} + +fun matchesPattern (tmpVal, pat) { + var result = case pat of + Wildcard -> true + | Named (name, pat) -> matchesPattern (tmpVal, pat) + | Number (num) -> + case tmpVal of + #val -> tmpVal == num + | _ -> false + esac + | String (s) -> + case tmpVal of + #str -> compare (tmpVal, s) == 0 + | _ -> false + esac + | Array (patArgs) -> + case tmpVal of + #array -> + var sizeEq = size (patArgs) == length (tmpVal); + if sizeEq + then + var valArgs = arrayList (tmpVal); + foldl ( + fun (acc, [patArg, valArg]) { + acc && matchesPattern (valArg, patArg) + } + , true, zip (patArgs, valArgs)) + else false + fi + | _ -> false + esac + | Sexp (patTag, patArgs) -> + case tmpVal of + S (valTag, valArgsArr) -> + var tagEq = compare (patTag, valTag) == 0; + var sizeEq = size (patArgs) == length (valArgsArr); + if tagEq && sizeEq + then + var valArgs = arrayList (valArgsArr); + foldl ( + fun (acc, [patArg, valArg]) { + acc && matchesPattern (valArg, patArg) + } + , true, zip (patArgs, valArgs)) + else false + fi + | _ -> false + esac + | _ -> false + esac; + -- printf("%s matches? %s => %d\n", tmpVal.string, pat.string, result); + result +} + fun eval (c@[s, w], expr) { - failure ("evalExpr not implemented\n") + -- printf ("Eval %s\n", string (expr)); + case expr of + Skip -> [c, V] + | Scope (defs, expr) -> + var s1 = foldl (fun (s, def) { + case def of + Var (names) -> addNames (s, names) + | Val (names) -> addNames (s, names) + | Fun (name, args, body) -> addFunction (s, name, args, body) + | _ -> failure (sprintf ("%s unimplemented", def.string)) + esac + }, enterScope (s), defs); + case eval ([s1, w], expr) of + [[s, w], x] -> [[leaveScope (s), w], x] + esac + | Ignore (expr) -> + case eval (c, expr) of + [c, _] -> [c, V] + esac + | Seq (lhs, rhs) -> + case evalList (c, {lhs, rhs}) of + [c, {lhs, rhs}] -> [c, rhs] + esac + | Assn (lhs, rhs) -> + case evalList (c, {lhs, rhs}) of + [[s, w], {R (name), rhs}] -> + -- printf ("%s := %s\n", name, string (rhs)); + [ [s <- [name, Val (rhs)], w], rhs ] + | [[s, w], {ER (arr, idx), rhs}] -> + arr[idx] := rhs; + [[s, w], rhs] + esac + | Set (name, expr) -> + case eval (c, expr) of + [[s, w], x] -> [ [s <- [name, Val (x)], w], x ] + esac + | Var (name) -> [c, lookupUnwrapVal (s, name)] + | Ref (name) -> [c, R (name)] + | Const (x) -> [c, x] + | String (string) -> + -- printf ("Evaluated into %s\n", string); + [c, string] + | Array (exprs) -> + case evalList (c, exprs) of + [c, elems] -> [c, listArray (elems)] + esac + | Sexp (tag, exprs) -> + case evalList (c, exprs) of + [c, elems] -> [c, S (tag, listArray (elems))] + esac + | Elem (arr, idx) -> + case evalList (c, {arr, idx}) of [c, {arr, idx}] -> + case arr of + S (tag, arr) -> [c, arr[idx]] + | arr -> [c, arr[idx]] + esac esac + | ElemRef (arr, idx) -> + case evalList (c, {arr, idx}) of + [c, {arr, idx}] -> [c, ER (arr, idx)] + esac + | Binop (op, lhs, rhs) -> + case evalList (c, {lhs, rhs}) of + [c, {lhs, rhs}] -> [c, evalOp (op, lhs, rhs)] + esac + | If (cond, bodyThen, bodyElse) -> + case eval (c, cond) of [c, condVal] -> + if condVal + then eval (c, bodyThen) + else eval (c, bodyElse) + fi + esac + | lp@While (cond, body) -> + case eval (c, cond) of [c, condVal] -> + if condVal + then eval (c, Seq (body, lp)) + else [c, V] + fi + esac + | DoWhile (cond, body) -> eval (c, Seq (body, While (cond, body))) + | Call (name, argExprs) -> + case evalList (c, argExprs) of [c@[s, w], argVals] -> + case lookupFun (s, name) of + Fun (argNames, External) -> + case evalBuiltin (name, argVals, w) of + [x, w] -> [[s, w], x] + esac + | Fun (argNames, body) -> + var s1 = foldl ( + fun (s, [name, x]) { s <- [name, Val (x)] } + , addNames (enterFunction (s), argNames) + , zip (argNames, argVals) + ); + case eval ([s1, w], body) of [[s1, w], x] -> + [[leaveFunction (s, getGlobal (s1)), w], x] + esac + esac + esac + | Case (tmpName, branches, [line, col]) -> + var tmpVal = lookupUnwrapVal (s, tmpName); + var retFun = foldr (fun (other, [pat, br]) { + if matchesPattern (tmpVal, pat) + then fun () { eval (c, br) } + else other + fi + }, fun () { + failure ( + "Value %s matched no pattern among %s at %d:%d\n" + , string (tmpVal) + , string (map (fst, branches)) + , line + , col + ) + }, branches); + retFun () + esac } diff --git a/src/Parser.lama b/src/Parser.lama index df3da2b61..5abb4877b 100644 --- a/src/Parser.lama +++ b/src/Parser.lama @@ -226,7 +226,91 @@ var esac, loc)} } | - $(failure ("the rest of primary parsing in not implemented\n"))), + loc=pos kSkip { fun (a) { assertVoid (a, returnST (Skip), loc) } } + | inbr[s("("), scopeExpr, s(")")] + -- | kRead s["("] x=lident s[")"] { fun (a) { Read (x) } } + -- | loc=pos kWrite s["("] x=exp s[")"] + -- { fun (a) { assertVoid (a, Write (x (Val)), loc) } } + | loc=pos kIf cond=exp kThen bodyThen=scopeExpr bodyElse=endIf { + fun (a) { + cond (Val) =>> fun (cond) { + bodyThen (a) =>> fun (bodyThen) { + bodyElse (a) => fun (bodyElse) { + If (cond, bodyThen, bodyElse) + } } } + } + } + | loc=pos kWhile cond=exp kDo body=scopeExpr kOd { + fun (a) { + assertVoid (a + , cond (Val) =>> fun (cond) { + body (Void) => fun (body) { + While (cond, body) + } } + , loc + ) + } + } + | loc=pos kDo body=scopeExpr kWhile cond=exp kOd { + fun (a) { + assertVoid (a + , cond (Val) =>> fun (cond) { + body (Void) => fun (body) { + distributeScope (body, fun (body) { + DoWhile (cond, body) + }) + } } + , loc + ) + } + } + | loc=pos kFor init=scopeExpr s[","] cond=exp s[","] iter=exp kDo body=scopeExpr kOd { + fun (a) { + assertVoid (a + , init (Void) =>> fun (init) { + cond (Val) =>> fun (cond) { + body (Void) =>> fun (body) { + iter (Void) => fun (iter) { + distributeScope (init, fun (init) { + Seq (init, While (cond, Seq (body, iter))) + }) + } } } } + , loc + ) + } + } + | loc=pos + kCase scrutinee=exp kOf + cases=listBy[ + syntax ( + pat=pattern s["->"] branch=scopeExpr { [pat, branch] } + ) + , s("|") + ] + kEsac { + fun (a) { + scrutinee (Val) =>> fun (scrutinee) { + var patBranches = foldr (fun (acc, [pat, branch]) { + acc =>> fun (acc) { + branch (a) => fun (branch) { + [pat, branch] : acc + } } + }, returnST ({}), cases); + + freshName =>> fun (tmpName) { + patBranches => fun (patBranches) { + var reified = reifyPatternBindings (tmpName, patBranches); + expandScope ( + { Val ({ [tmpName, scrutinee] }) } + , Case (tmpName, reified, loc) + ) + } } + } + } + } + -- | + -- $(failure ("the rest of primary parsing in not implemented\n")) + ), basic = memo $ eta ( @@ -317,5 +401,34 @@ var } ); +var endIf = memo $ eta syntax ( + loc=pos kFi { fun (a) { assertVoid (a, returnST (Skip), loc) } } +| kElse body=scopeExpr kFi { body } +| kElif cond=scopeExpr kThen bodyThen=scopeExpr bodyElse=endIf { + fun (a) { + cond (Val) =>> fun (cond) { + bodyThen (a) =>> fun (bodyThen) { + bodyElse (a) => fun (bodyElse) { + If (cond, bodyThen, bodyElse) + } } } + } + } +); + +var pattern = memo $ eta syntax ( + s["_"] { Wildcard } +| name=lident s["@"] pat=pattern { Named (name, pat) } +| name=lident { Named (name, Wildcard) } +| s["["] items=list0[pattern] s["]"] { Array (items) } +| tag=uident args=inbr[s("("), list0(pattern), s(")")]? { + case args of + None -> Sexp (tag, {}) + | Some (args) -> Sexp (tag, args) + esac + } +| x=decimal { Number (stringInt(x)) } +| x=strlit { String (x) } +); + -- Public top-level parser public parse = syntax (s=scopeExpr {s (Void) (emptyEnv ()) [1]}); diff --git a/src/SM.lama b/src/SM.lama index 059af9047..42d58245a 100644 --- a/src/SM.lama +++ b/src/SM.lama @@ -53,6 +53,7 @@ public fun showSMInsn (i) { | BUILTIN (f, n) -> sprintf ("BUILTIN %s, %d", f, n) | META (m) -> sprintf ("META %s", m.string) | PATT (p) -> sprintf ("PATT %s", p.string) + | MATCH_FAILURE ([line, col]) -> sprintf ("MATCH_FAILURE at %d:%d", line, col) esac } @@ -100,7 +101,6 @@ fun eval (env, w, insns) { case loc of Arg (i) -> args[i] | Loc (i) -> locs[i] - | Loc (i) -> locs[i] | Glb (x) -> deref (globalState) (x) esac } @@ -129,8 +129,104 @@ fun eval (env, w, insns) { } -- Core interpreter: takes a configuration and a program, returns a configuration - fun eval (c@[st, cst, s, w], insns) { - failure ("SM interpreter is not implemented\n") + fun eval (conf@[stack, cst, state, world], prog) { + case prog of + {} -> conf + | ins : prog -> + -- printf ("ins = %s, stack = %s, state = %s\n", ins.string, stack.string, state.string); + case ins of + DUP -> case stack of x : stack -> eval ([x : x : stack, cst, state, world], prog) esac + | DROP -> case stack of x : stack -> eval ([stack, cst, state, world], prog) esac + | CONST (x) -> eval ([x : stack, cst, state, world], prog) + | STRING (string) -> eval ([string : stack, cst, state, world], prog) + | ARRAY (n) -> + case take (stack, n) of [_ : stack, elems] -> + var x = listArray (elems); + eval ([x : stack, cst, state, world], prog) + esac + | SEXP (tag, n) -> + case take (stack, n) of [_ : stack, elems] -> + var x = S (tag, listArray (elems)); + eval ([x : stack, cst, state, world], prog) + esac + | LD (name) -> eval ([lookup (state, name) : stack, cst, state, world], prog) + | ST (name) -> + case stack of x : stack -> + assign (state, name, x); + eval ([stack, cst, state, world], prog) + esac + | LDA (name) -> eval ([name : stack, cst, state, world], prog) + | STI -> + case stack of name : x : stack -> + assign (state, name, x); + eval ([stack, cst, state, world], prog) + esac + | ELEM -> + case stack of + idx : S (_, arr) : stack -> eval ([arr[idx] : stack, cst, state, world], prog) + | idx : arr : stack -> eval ([arr[idx] : stack, cst, state, world], prog) + esac + | STA -> + case stack of + x : V : name : stack -> + assign (state, name, x); + eval ([x : stack, cst, state, world], prog) + | x : idx : arr : stack -> + arr[idx] := x; + eval ([x : stack, cst, state, world], prog) + esac + | BINOP (op) -> + case stack of y : x : stack -> + var z = evalOp (op, x, y); + eval ([z : stack, cst, state, world], prog) + esac + | PATT (Tag (patTag, nPatArgs)) -> + case stack of x : stack -> + var matches = case x of + S (valTag, valArgs) -> + compare (patTag, valTag) == 0 && + nPatArgs == length (valArgs) + | _ -> false + esac; + eval ([matches : stack, cst, state, world], prog) + esac + | LABEL (lab, fwd) -> eval (conf, prog) + | JMP (lab) -> eval (conf, fromLabel (env, lab)) + | CJMP ("nz", lab) -> case stack of x : stack -> + if x != 0 + then eval ([stack, cst, state, world], fromLabel (env, lab)) + else eval ([stack, cst, state, world], prog) + fi esac + | CJMP ("z", lab) -> case stack of x : stack -> + if x == 0 + then eval ([stack, cst, state, world], fromLabel(env, lab)) + else eval ([stack, cst, state, world], prog) + fi esac + | CALL (fn, argCount) -> eval ([stack, [state, prog] : cst, state, world], fromLabel (env, fn)) + | BUILTIN (fn, argCount) -> + case take (stack, argCount) of [stack, args] -> + case evalBuiltin (fn, args, world) of [x, world] -> + eval ([x : stack, cst, state, world], prog) + esac esac + | BEGIN (fn, argCount, localsCount) -> + case take (stack, argCount) of [stack, args] -> + eval( + [ stack + , cst + , [listArray (args), initArray (localsCount, fun (_) { 0 })] + , world + ] + , prog + ) + esac + | GLOBAL (name) -> eval (conf, prog) + | END -> + case cst of + {} -> conf + | [state, prog] : cst -> eval ([stack, cst, state, world], prog) + esac + esac + esac } @@ -211,6 +307,7 @@ fun makeCompEnv (nLabels, scopeDepth, state, nLocals, nArgs, functions) { fun lookupVar (name) { case lookup (state, name) of Loc (i, true) -> Loc (i) + | Arg (i) -> Arg (i) | Glb (x, true) -> Glb (x) | _ -> error (sprintf ("the name ""%s"" does not designate a variable", name), getLoc (name)) esac @@ -370,6 +467,17 @@ fun addVals (env, names) { foldl (fun (env, name) {addVal (env, name)}, env, names) } +fun nthItem (xs, n) { + if n >= 0 + then + case [xs, n] of + [x : xs, 0] -> x + | [x : xs, n] -> nthItem (xs, n - 1) + esac + else failure ("Negative index") + fi +} + -- Compiles an expression into a stack machine code. -- Takes an expression, returns a list of stack machine -- instructions. @@ -396,27 +504,313 @@ fun addVals (env, names) { public fun compileSM (stmt) { fun label (lab, labUsed) { if labUsed - then singletonBuffer (LABEL (lab)) + then singletonBuffer (LABEL (lab, false)) else emptyBuffer () fi } + fun compileInner (env, expr) { + case genLabel (env) of [lab, env] -> + case compile (lab, env, expr) of [labUsed, env, exprCode] -> + [env, exprCode <+> label (lab, labUsed)] + esac esac + } + + fun appendIns (env, expr, ins) { + case compileInner (env, expr) of + [env, code] -> [false, env, code <+ ins] + esac + } + + fun makeLoop (lab, env, cond, body, skipInit) { + case env.genLabel of [bodyBegLab, env] -> + case env.genLabel of [condLab, env] -> + case compile (condLab, env, body) of [condLabUsed, env, bodyCode] -> + case compile (lab, env, cond) of [labUsed, env, condCode] -> + [ labUsed , env + , if skipInit + then singletonBuffer (JMP (condLab)) + else emptyBuffer() + fi + <+ LABEL (bodyBegLab, skipInit) + <+> bodyCode + <+> label (condLab, skipInit !! condLabUsed) + <+> condCode + <+ CJMP ("nz", bodyBegLab) + ] + esac esac esac esac + } + + fun compileMany (env, exprs) { + foldl(fun ([env, code], expr) { + case genLabel (env) of [lab, env] -> + case compile (lab, env, expr) of [used, env, newCode] -> + [env, code <+> newCode <+> label (lab, used)] + esac esac + }, [env, emptyBuffer ()], exprs) + } + + fun compilePattern (env, exitLabs, stackLevel, pat) { + fun compileSubpat ([env, exitLabs, code, i], pat) { + case compilePattern (env, exitLabs, stackLevel + 1, pat) of [env, patCode, exitLabs] -> + [ env + , exitLabs + , if patCode == {} then + code + else + code + <+ DUP + <+ CONST (i) + <+ ELEM + <+> patCode + <+ DROP + fi + , i + 1 + ] + esac + } + + if stackLevel >= size (exitLabs) then + case genLabel (env) of + [newLab, env] -> compilePattern (env, newLab : exitLabs, stackLevel, pat) + esac + else + var thisExitLab = nthItem (exitLabs, size (exitLabs) - 1 - stackLevel); + -- printf ("Pattern: %s => thisExitLab: %s, stackLevel: %d, exitLabs: %s\n", pat.string, thisExitLab, stackLevel, exitLabs.string); + + case pat of + Wildcard -> [env, emptyBuffer (), exitLabs] + | Named (_, pat) -> compilePattern (env, exitLabs, stackLevel, pat) + | Number (num) -> + [ env + , singletonBuffer (DUP) + <+ CONST (num) + <+ BINOP ("==") + <+ CJMP ("z", thisExitLab) + , exitLabs + ] + | Sexp (patTag, patArgs) -> + var subpats = foldl ( + compileSubpat + , [ env + , exitLabs + , singletonBuffer (DUP) + <+ PATT (Tag (patTag, size (patArgs))) + <+ CJMP ("z", thisExitLab) + , 0 + ] + , patArgs + ); + + case subpats of [env, exitLabs, code, _] -> + -- printf ("Pattern %s => %s\n", pat.string, code.getBuffer.string); + [env, code, exitLabs] + esac + esac + fi + } + fun compile (lab, env, stmt) { + -- printf ("N locals = %d, compiling %s\n", getLocals (env), string (stmt)); case stmt of - Skip -> [false, env, emptyBuffer ()] - | Var (x) -> [false, env, singletonBuffer (LD (x))] - | Ref (x) -> [false, env, singletonBuffer (LDA (x))] - | Const (n) -> [false, env, singletonBuffer (CONST (n))] - | _ -> failure ("compileSM not implemented\n") + Skip -> [false, env, emptyBuffer ()] + | Var (name) -> [false, env, singletonBuffer (LD (lookupVal (env, name)))] + | Ref (name) -> [false, env, singletonBuffer (LDA (lookupVar (env, name))) <+ CONST (V)] + | Const (x) -> [false, env, singletonBuffer (CONST (x))] + | Ignore (expr) -> appendIns (env, expr, DROP) + | Seq (lhs, rhs) -> + case compileInner (env, lhs) of [env, lhsCode] -> + case compile (lab, env, rhs) of [labUsed, env, rhsCode] -> + [labUsed, env, lhsCode <+> rhsCode] + esac esac + | Assn (Ref (x), rhs) -> + case compileInner (env, rhs) of [env, rhsCode] -> + [false, env, rhsCode <+ DUP <+ ST (lookupVar (env, x))] + esac + | Assn (lhs, rhs) -> + case compileMany (env, {lhs, rhs}) of + [env, code] -> [false, env, code <+ STA] + esac + | Set (name, rhs) -> + case compileInner (env, rhs) of [env, rhsCode] -> + [false, env, rhsCode <+ DUP <+ ST (lookupVal (env, name))] + esac + | Binop (op, lhs, rhs) -> + case compileInner (env, lhs) of [env, lhsCode] -> + case compileInner (env, rhs) of [env, rhsCode] -> + [false, env, lhsCode <+> rhsCode <+ BINOP (op)] + esac esac + | If (cond, bodyThen, bodyElse) -> + case compileInner (env, cond) of [env, condCode] -> + case genLabel (env) of [elseBegLab, env] -> + case compile (lab, env, bodyThen) of [_, env, bodyThenCode] -> + case compile (lab, env, bodyElse) of [_, env, bodyElseCode] -> + [ true , env + , condCode + <+ CJMP ("z", elseBegLab) + <+> bodyThenCode + <+ JMP (lab) + <+ LABEL (elseBegLab, 0) + <+> bodyElseCode + ] + esac esac esac esac + | While (cond, body) -> makeLoop (lab, env, cond, body, true) + | DoWhile (cond, body) -> makeLoop (lab, env, cond, body, false) + | Scope (defs, expr) -> + fun genGlobals (vars) { + foldl (fun (code, x) { code <+ GLOBAL (x) }, emptyBuffer (), vars) + } + + var traversed1 = foldl (fun ([code, env, funcs], def) { + case def of + Var (vars) -> + [ if isGlobal (env) + then code <+> genGlobals (vars) + else code + fi + , addVars (env, vars) + , funcs + ] + | Val (vals) -> + [ if isGlobal (env) + then code <+> genGlobals (vals) + else code + fi + , addVals (env, vals) + , funcs + ] + | Fun (fn, args, body) -> + case genFunLabel (env, fn) of + [lab, env] -> [code, addFun (env, fn, lab, size (args)), Fun (lab, args, body) : funcs] + esac + esac + }, [emptyBuffer (), beginScope (env), {}], defs); + + case traversed1 of [defsCode, env, funcs] -> + var traversed2 = foldl (fun (env, Fun (fn, args, body)) { + rememberFun (env, fn, args, body) + }, env, funcs); + + case compile (lab, traversed2, expr) of [flag, env, code] -> + [flag, endScope (env), defsCode <+> code] + esac esac + | Call (fn, argExprs) -> + case compileMany (env, argExprs) of [env, code] -> + case lookupFun (env, fn) of Fun (label, argCount) -> + [ false, env, code <+ + if label[0] == '$' -- compare (substring (label, 0, 1), "$") == 0 + then BUILTIN (fn, argCount) + else CALL (label, argCount) + fi + ] + esac esac + | String (string) -> [false, env, singletonBuffer (STRING (string))] + | Array (exprs) -> + var n = size (exprs); + case compileMany (env, exprs) of [env, code] -> + [ false, env + , singletonBuffer (CONST (n)) + <+> code + <+ ARRAY (size (exprs)) + ] + esac + | Sexp (tag, exprs) -> + var n = size (exprs); + case compileMany (env, exprs) of [env, code] -> + [ false, env + , singletonBuffer (CONST (n + 1)) + <+> code + <+ SEXP (tag, n) + ] + esac + | Elem (arr, idx) -> + case compileMany (env, {arr, idx}) of + [env, code] -> [false, env, code <+ ELEM] + esac + | ElemRef (arr, idx) -> + case compileMany (env, {arr, idx}) of + [env, code] -> [false, env, code] + esac + | Case (tmpName, branches, loc) -> + var branchesEnvCode = foldl (fun ([env, code], [pat, br]) { + case genLabel (env) of [elseLab, env] -> + case compilePattern (env, {elseLab}, 0, pat) of [env, patCode, exitLabs] -> + case compile (lab, env, br) of [_, env, brCode] -> + var cleanupCode1 = foldr (fun (acc, lab) { + DROP : LABEL (lab, false) : acc + }, {}, exitLabs); + var cleanupCode2 = tl (cleanupCode1); + -- var cleanupCode3 = reverse (cleanupCode2); + var cleanupCode = listBuffer (cleanupCode2); + + -- printf ("Pat code: %s\n", patCode.getBuffer.string); + -- printf ("BR code: %s\n", brCode.getBuffer.string); + -- printf ("Cleanup code: %s\n", cleanupCode.getBuffer.string); + + [ env + , code + <+> patCode + <+ DROP + <+> brCode + <+ JMP (lab) + <+> cleanupCode + ] + esac esac esac + }, [env, singletonBuffer (LD (lookupVal (env, tmpName)))], branches); + + var patterns = map (fst, branches); + + case branchesEnvCode of [env, code] -> + [ true + , env + , code + <+ MATCH_FAILURE (loc) + ] + esac + | _ -> failure ("Cannot compile %s\n", string (stmt)) esac } + fun compileFuncs (env, start) { + fun traverse (env, funcs) { + -- printf ("funcs = %s\n\n\n", string (funcs)); + case funcs of + {} -> + case getFuns (env) of + [{}, env] -> emptyBuffer () + | [funcs, env] -> traverse (env, funcs) + esac + | Fun (fn, args, expr, state) : funcs -> + var tmp1 = beginFun (env, state); + var tmp2 = addArgs (tmp1, args); + var tmp3 = compileInner (tmp2, expr); + case tmp3 of [env, code] -> + singletonBuffer (LABEL (fn, false)) + <+ BEGIN (fn, size (args), getLocals (env)) + <+> code + <+ END + <+> traverse (env, funcs) + esac + esac + } + + var newCode = traverse (env, {}); + start <+> newCode + } + case initCompEnv ().beginScope.addFun ("read" , "$read" , 0) .addFun ("write" , "$write" , 1) .addFun ("length", "$length", 1).genLabel of [endLab, env] -> - case compile (endLab, env, stmt) of - [endLabUsed, _, code] -> getBuffer $ code <+> label (endLab, endLabUsed) - esac + case compile (endLab, env, stmt) of [endLabUsed, env, code] -> + var result = getBuffer $ compileFuncs (env + , singletonBuffer (LABEL ("main", false)) + <+ BEGIN ("main", 0, getLocals (env)) + <+> code <+> label (endLab, endLabUsed) + <+ END + ); + -- printf ("%s\n", showSM (result)); + result + esac esac } diff --git a/src/X86.lama b/src/X86.lama index 499b0c842..b160d77f3 100644 --- a/src/X86.lama +++ b/src/X86.lama @@ -489,6 +489,32 @@ fun toFixedNum (r) { -- and stack machine code, returns an updated environment and x86 code. fun compile (args, env, code) { fun compile (env, code) { + fun compileCall (env, code, lab, argCount) { + var regs = liveRegisters (env, argCount); + var restoreCode = foldr (fun (code, reg) { + code <+ Pop (reg) + }, emptyBuffer (), regs); + + code := foldl (fun (code, reg) { + code <+ Push (reg) + }, code, regs); + + for var i; i := 0, i < argCount, i := i + 1 do + case pop (env) of [reg, env1] -> + code := code <+ Push (reg); + env := env1 + esac + od; + case allocate (env) of [top, env] -> + [ env, code + <+ Call (lab) + <+ Binop ("+", L (wordSize * argCount), esp) + <+> restoreCode + <+> move (eax, top) + ] + esac + } + foldl ( fun ([env, scode], i) { var code = scode <+ Meta ("# " ++ showSMInsn (i) ++ "\n"); @@ -534,7 +560,190 @@ fun compile (args, env, code) { -- env.enterFunction to create a proper environment; -- 2. generate epilogue for END instruction. - | _ -> failure ("codegeneration for instruction %s is not yet implemented\n", i.string) + | DUP -> + var sx = peek (env); + case allocate (env) of + [sy, env] -> [env, code <+> move (sx, sy)] + esac + | DROP -> + case pop (env) of + [s, env] -> [env, code] + esac + | CONST (x) -> + var xv = + case x of + V -> 0 + | _ -> 2 * x + 1 + esac; + case allocate (env) of + [s, env] -> [env, code <+> move (L (xv), s)] + esac + | STRING (string) -> + case addString (env, string) of [env, name] -> + case allocate (env) of [s, env] -> + var lx = M (name); + compileCall (env + , code + <+ Lea (lx, eax) + <+ Mov (eax, s) + , "Bstring", 1) + esac esac + | ARRAY (n) -> compileCall (env, code, "Barray", n + 1) + | SEXP (tag, n) -> + case allocate (env) of [st, env] -> + compileCall ( + env + , code <+> move (L (makeBox (tagHash (tag))), st) + , "Bsexp" + , n + 2 + ) + esac + | LD (name) -> + var lx = loc (env, name); + case allocate (env) of + [s, env] -> [env, code <+> move (lx, s)] + esac + | ST (name) -> + case pop (env) of [s, env] -> + var lx = loc (env, name); + [env, code <+> move (s, lx)] + esac + | LDA (name) -> + case allocate (env) of [s, env] -> + var lx = loc (env, name); + [env, code <+ Lea (lx, eax) <+> move (eax, s)] + esac + | STI -> + case pop2 (env) of [si, sx, env] -> + [env, code <+> move (sx, I (0, si))] + esac + | ELEM -> compileCall (env, code, "Belem", 2) + | STA -> compileCall (env, code, "Bsta", 3) + | BINOP (op) -> + case pop2 (env) of [sy, sx, env] -> + case allocate (env) of [sz, env] -> + fun basicArithm () { + code + <+ Mov (sx, eax) + <+ Mov (sy, edx) + <+ Sar1 (eax) + <+ Sar1 (edx) + <+ Binop (op, edx, eax) + <+ Sal1 (eax) + <+ Or1 (eax) + <+> move (eax, sz) + } + fun divRem (endReg) { + code + <+> move (sx, eax) + <+ Sar1 (eax) + <+ Sar1 (sy) + <+ Cltd + <+ IDiv (sy) + <+ Sal1 (endReg) + <+ Or1 (endReg) + <+> move (endReg, sz) + } + fun comparison () { + code + <+ Binop ("^", eax, eax) + <+ Mov (sx, edx) + <+ Sar1 (edx) + <+ Sar1 (sy) + <+ Binop ("cmp", sy, edx) + <+ Set (suffix (op), "%al") + <+ Sal1 (eax) + <+ Or1 (eax) + <+> move (eax, sz) + } + fun logical () { + code + <+ Binop("^", eax, eax) + <+ Binop("^", edx, edx) + <+ Binop("cmp", L (1), sx) + <+ Set (suffix ("!="), "%al") + <+ Binop("cmp", L (1), sy) + <+ Set (suffix ("!="), "%dl") + <+ Binop (op, edx, eax) + <+ Sal1 (eax) + <+ Or1 (eax) + <+ Mov (eax, sz) + } + var newCode = case op of + "+" -> basicArithm () + | "-" -> basicArithm () + | "*" -> basicArithm () + | "/" -> divRem (eax) + | "%" -> divRem (edx) + | "<" -> comparison () + | ">" -> comparison () + | "<=" -> comparison () + | ">=" -> comparison () + | "==" -> comparison () + | "!=" -> comparison () + | "&&" -> logical () + | "!!" -> logical () + esac; + + [env, newCode] + esac esac + + -- | ELEM -> compileCall (env, code, "Belem", 2) + | PATT (Tag (patTag, nPatArgs)) -> + case allocate (env) of [st, env] -> + case allocate (env) of [sn, env] -> + compileCall ( + env + , code + <+> move (L (makeBox (tagHash (patTag))), st) + <+> move (L (makeBox (nPatArgs)), sn) + , "Btag" + , 3 + ) + esac esac + | MATCH_FAILURE ([line, col]) -> + case addString (env, "") of [env, emptyStr] -> + case allocate (env) of [sfname, env] -> + case allocate (env) of [sline, env] -> + case allocate (env) of [scol, env] -> + compileCall ( + env + , code + <+ Lea (M (emptyStr), eax) + <+ Mov (eax, sfname) + <+> move (L (makeBox (line)), sline) + <+> move (L (makeBox (col)), scol) + , "Bmatch_failure" + , 4 + ) + esac esac esac esac + | LABEL (lab, _) -> + [ if isBarrier (env) + then retrieveStack (env, lab) + else env + fi + , code <+ Label (lab) + ] + | JMP (lab) -> [setBarrier (setStack (env, lab)), code <+ Jmp (lab)] + | CJMP (mod, lab) -> + case pop (env) of [s, env] -> + [ setStack (env, lab), code + <+> move (s, eax) + <+ Sar1 (eax) + <+ Binop ("cmp", L (0), eax) + <+ CJmp (mod, lab) + ] + esac + | CALL (fn, argCount) -> compileCall (env, code, fn, argCount) + | BUILTIN (fn, argCount) -> compileCall (env, code, "L" ++ fn, argCount) + | BEGIN (fn, argCount, localsCount) -> + [enterFunction (env, fn, localsCount), code <+> prologue (fn)] + | GLOBAL (name) -> [addGlobal (env, name), code] + | END -> + case epilogue (env) of + [env, xcode] -> [env, code <+> xcode] + esac + | _ -> failure ("codegeneration for instruction %s is not yet implemented\n", string (i)) esac fi }, [env, emptyBuffer ()], code)