diff --git a/src/Expr.lama b/src/Expr.lama index 3c9d9fa9d..1b34911e1 100644 --- a/src/Expr.lama +++ b/src/Expr.lama @@ -3,6 +3,7 @@ import List; import State; import World; +-- import Utils; -- As association map which maps "\otimes" into "\oplus" var ops = { @@ -23,9 +24,21 @@ var ops = { -- The evaluator for infix operators: takes an operator as a string -- and two operand values, and returns the result -public fun evalOp (op, l, r) { - case assoc (ops, op) of - Some (f) -> f (l, r) +public fun evalOp (bop, left, right) { + case bop of + "+" -> left + right + | "-" -> left - right + | "*" -> left * right + | "/" -> left / right + | "%" -> left % right + | "!!" -> left !! right + | "&&" -> left && right + | "==" -> left == right + | "!=" -> left != right + | "<=" -> left <= right + | "<" -> left < right + | ">=" -> left >= right + | ">" -> left > right esac } @@ -49,33 +62,64 @@ public fun evalOp (op, l, r) { -- Binop (string, expr, expr) | -- Ignore (expr) -public fun evalBinop (left, right, bop) { - case bop of - "+" -> left + right - | "-" -> left - right - | "*" -> left * right - | "/" -> left / right - | "%" -> left % right - | "!!" -> left !! right - | "&&" -> left && right - | "==" -> left == right - | "!=" -> left != right - | "<=" -> left <= right - | "<" -> left < right - | ">=" -> left >= right - | ">" -> left > right - esac -} - -public fun evalExpr (st, expr) { - case expr of - Var (varName) -> st(varName) - | Const (n) -> n - | Binop (bop, left, right) -> evalBinop(evalExpr(st, left), evalExpr(st, right), bop) +public fun eval (conf@[state, world], expr) { + case expr of + Skip -> [conf, Nothing] + | Var (varName) -> [conf, state (varName)] + | Const (n) -> [conf, n] + | Ref (r) -> [conf, r] + | Read (varExpr) -> + case eval (conf, varExpr) of + [[state, world], varName] -> + case readWorld(world) of + [value, newWorld] -> [[state <- [varName, value], newWorld], Nothing] + esac + esac + | Write (expr) -> + case eval (conf, expr) of + [[state, world], value] -> [[state, writeWorld (value, world)], Nothing] + esac + | Binop (bop, left, right) -> + case eval (conf, left) of + [conf, leftValue] -> + case eval (conf, right) of + [conf, rightValue] -> + [conf, evalOp (bop, leftValue, rightValue)] + esac + esac + | Ignore (expr) -> + case eval(conf, expr) of + [conf, _] -> [conf, Nothing] + esac + | Assn (targetNode, valueNode) -> + case eval (conf, targetNode) of + [conf, varName] -> + case eval (conf, valueNode) of + [[state, world], value] -> [[state <- [varName, value], world], value] + esac + esac + | Seq (head, tail) -> + case eval (conf, head) of + [conf, _] -> eval (conf, tail) + esac + | If (condition, ifBody, elseBody) -> + case eval (conf, condition) of + [conf, 0] -> eval (conf, elseBody) + | [conf, n] -> eval (conf, ifBody) + esac + | node@While (condition, body) -> + case eval (conf, condition) of + [conf, 0] -> [conf, Nothing] + | [conf, _] -> + case eval (conf, body) of + [conf, _] -> eval (conf, node) + esac + esac + | DoWhile (body, condition) -> eval (conf, Seq (body, While (condition, body))) + | other -> failure (other.string) esac } - -- Evaluates a program with a given input and returns an output public fun evalExpr (input, expr) { case eval ([emptyState, createWorld (input)], expr) of diff --git a/src/Parser.lama b/src/Parser.lama index 21c0724a3..a8d5a524b 100644 --- a/src/Parser.lama +++ b/src/Parser.lama @@ -43,7 +43,6 @@ fun inbr (l, p, r) { syntax (-l p -r) } -<<<<<<< HEAD fun binop (op) { [syntax (pos -s[op]), fun (l, loc, r) { fun (a) { @@ -54,6 +53,7 @@ fun binop (op) { } var primary = memo $ eta syntax ( + x=inbr[s("("), exp, s(")")] {eta x} | -- decimal constant loc=pos x=decimal {fun (a) {assertValue (a, Const (stringInt (x)), loc)}} | @@ -65,7 +65,14 @@ var primary = memo $ eta syntax ( | _ -> Var (x) esac }} | - $(failure ("the rest of primary parsing in not implemented\n"))), + ifHead | + loc=pos kSkip {fun (a) {assertVoid (a, Skip, loc)}} | + + kRead loc=pos x=inbr[s("("), exp, s(")")] {fun (a) {assertVoid (a, Read (x (Ref)), loc)}} | + kWrite loc=pos x=inbr[s("("), exp, s(")")] {fun (a) {assertVoid (a, Write (x (Val)), loc)}} | + kWhile loc=pos condition=exp kDo body=exp kOd {fun (a) {assertVoid (a, While (condition (Val), body (Void)), loc)}} | + kDo loc=pos body=exp kWhile condition=exp kOd {fun (a) {assertVoid (a, DoWhile (body (Void), condition (Val)), loc)}} | + kFor loc=pos iterator=exp s[","] condition=exp s[","] step=exp kDo body=exp kOd {fun (a) {assertVoid (a, Seq (iterator (Void), While(condition (Val), Seq(body (Void), step (Void)))), loc)}}), basic = memo $ eta (expr ({[Right, {[s (":="), fun (l, loc, r) { fun (a) {assertValue (a, Assn (l (Ref), r (Val)), loc)} @@ -77,52 +84,11 @@ var primary = memo $ eta syntax ( [Left , map (binop, {"*", "/", "%"})] }, primary)), + ifHead = memo $ eta syntax (kIf condition=exp kThen body=exp tail=ifTail {fun (a) {If (condition (Val), body (a), tail (a))}}), + ifTail = memo $ eta syntax (kElif condition=exp kThen body=exp tail=ifTail {fun (a) {If (condition (Val), body (a), tail (a))}} | + kElse body=exp kFi {eta body} | + loc=pos kFi {fun (a) {assertVoid (a, Skip, loc)}}), exp = memo $ eta syntax (basic | s1=basic s[";"] s2=exp {fun (a) {Seq (s1 (Void), s2 (a))}}); -- Public top-level parser public parse = syntax (s=exp {s (Void)}); -======= -fun parens(p) { - inbr (s ("("), p, s (")")) -} - -fun binop (l, bop, r) { - Binop (bop, l, r) -} - --- Primary expression -var primary = memo $ eta syntax (x=decimal {Const (stringInt (x))} | - x=lident {Var (x)} | - inbr[s("("), exp, s(")")]), - exp = memo $ eta expr ({ - [Left, {[s ("!!"), binop]}], - [Left, {[s ("&&"), binop]}], - [Nona, {[s ("<"), binop], [s ("<="), binop], [s (">"), binop], [s (">="), binop], [s ("=="), binop], [s ("!="), binop]}], - [Left, {[s ("+"), binop], [s ("-"), binop]}], - [Left, {[s ("*"), binop], [s ("/"), binop], [s ("%"), binop]}] - }, primary), - ifHead = memo $ eta syntax (kIf condition=exp kThen body=stmts tail=ifTail {If (condition, body, tail)}), - ifTail = memo $ eta syntax (kElif condition=exp kThen body=stmts tail=ifTail {If (condition, body, tail)} | - kElse body=stmts kFi {body} | - kFi {Skip}); - -var stmt = memo $ eta syntax ( - kRead x=parens[lident] {Read (x)} | - kWrite x=parens[exp] {Write (x)} | - kSkip {Skip} | - target=lident s[":="] value=exp {Assn (target, value)} | - ifStmt=ifHead {ifStmt} | - kWhile condition=exp kDo body=stmts kOd {While (condition, body)} | - kDo body=stmts kWhile condition=exp kOd {DoWhile(body, condition)} | - kFor iterator=stmts s[","] condition=exp s[","] step=stmts kDo body=stmts kOd {Seq (iterator, While(condition, Seq(body, step)))} -); - -var stmts = memo $ eta syntax ( - stmt | - head=stmt s[";"] tail=stmts {Seq (head, tail)} -); - - --- Public top-level parser -public parse = stmts; ->>>>>>> 2ad0c4f (Implement control flow compiler) diff --git a/src/SM.lama b/src/SM.lama index a37cd2ea8..c644742d2 100644 --- a/src/SM.lama +++ b/src/SM.lama @@ -74,12 +74,22 @@ fun evalSingle (env, conf@[stack, state, world], instruction) { [None, [tl(stack), state, writeWorld(hd(stack), world)]] | BINOP (bop) -> case stack of - snd:fst:tail -> [None, [evalBinop(fst, snd, bop):tail, state, world]] + snd:fst:tail -> [None, [evalOp(bop, fst, snd):tail, state, world]] esac | LD (varName) -> [None, [state(varName):stack, state, world]] + | LDA (varName) -> + [None, [REF (varName):stack, state, world]] | ST (varName) -> [None, [stack, state <- [varName, hd(stack)], world]] + | STI -> + case stack of + (value:REF (varName):tail) -> [None, [value:tail, state <- [varName, value], world]] + esac + | DROP -> + case stack of + (_:tail) -> [None, [tail, state, world]] + esac | CONST (n) -> [None, [n:stack, state, world]] | LABEL (_) -> [None, conf] @@ -159,11 +169,53 @@ public fun compileSM (stmt) { fun compile (lab, env, stmt) { case stmt of - Skip -> [false, env, emptyBuffer ()] - | Read (x) -> [false, env, singletonBuffer (READ) <+ ST (x)] - | Write (e) -> [false, env, compileExpr (e) <+ WRITE] - | Assn (x, e) -> [false, env, compileExpr (e) <+ ST (x)] - | Seq (s1, s2) -> + Skip -> [false, env, emptyBuffer ()] + | Var (varName) -> [false, env, singletonBuffer (LD (varName))] + | Ref (varName) -> [false, env, singletonBuffer (LDA (varName))] + | Const (n) -> [false, env, singletonBuffer (CONST (n))] + | Read (x) -> + case env.genLabel of + [lab, env] -> + case compile (lab, env, x) of + [labUsed, env, code] -> [false, env, code <+> label (lab, labUsed) <+ READ <+ STI <+ DROP] + esac + esac + | Write (e) -> + case env.genLabel of + [lab, env] -> + case compile (lab, env, e) of + [labUsed, env, code] -> [false, env, code <+> label (lab, labUsed) <+ WRITE] + esac + esac + | Assn (x, e) -> + case env.genLabels (2) of + [xLab, eLab, env] -> + case compile (eLab, env, e) of + [eLabUsed, env, eCode] -> + case compile (xLab, env, x) of + [xLabUsed, env, xCode] -> [false, env, xCode <+> label (xLab, xLabUsed) <+> eCode <+> label (eLab, eLabUsed) <+ STI] + esac + esac + esac + | Ignore (e) -> + case env.genLabel of + [lab, env] -> + case compile (lab, env, e) of + [labUsed, env, code] -> [false, env, code <+> label(lab, labUsed) <+ DROP] + esac + esac + | Binop (bop, left, right) -> + case env.genLabels (2) of + [leftLab, rightLab, env] -> + case compile (leftLab, env, left) of + [leftLabUsed, env, leftCode] -> + case compile (rightLab, env, right) of + [rightLabUsed, env, rightCode] -> + [false, env, leftCode <+> label (leftLab, leftLabUsed) <+> rightCode <+> label (rightLab, rightLabUsed) <+ BINOP (bop)] + esac + esac + esac + | Seq (s1, s2) -> case env.genLabel of [s2Lab, env] -> case compile (s2Lab, env, s1) of @@ -174,20 +226,27 @@ public fun compileSM (stmt) { esac esac | If (condition, ifBranch, elseBranch) -> - case env.genLabel of - [elseBranchLab, env] -> - case compile (lab, env, ifBranch) of - [_, env, ifBranchCode] -> - case compile (lab, env, elseBranch) of - [_, env, elseBranchCode] -> [true, env, compileExpr (condition) <+ CJMP ("z", elseBranchLab) <+> ifBranchCode <+ JMP (lab) <+ LABEL (elseBranchLab) <+> elseBranchCode] + case env.genLabels (2) of + [conditionLab, elseBranchLab, env] -> + case compile (lab, env, condition) of + [conditionLabUsed, env, conditionCode] -> + case compile (lab, env, ifBranch) of + [_, env, ifBranchCode] -> + case compile (lab, env, elseBranch) of + [_, env, elseBranchCode] -> + [true, env, conditionCode <+> label (conditionLab, conditionLabUsed) <+ CJMP ("z", elseBranchLab) <+> ifBranchCode <+ JMP (lab) <+ LABEL (elseBranchLab) <+> elseBranchCode] + esac esac esac esac | While (condition, body) -> - case env.genLabels (2) of - [conditionLab, bodyLab, env] -> - case compile (conditionLab, env, body) of - [_, env, bodyCode] -> [true, env, singletonBuffer (LABEL (conditionLab)) <+> compileExpr (condition) <+ CJMP ("z", lab) <+> bodyCode <+ JMP (conditionLab)] + case env.genLabels (3) of + [afterConditionLab, beforeConditionLab, bodyLab, env] -> + case compile (afterConditionLab, env, condition) of + [afterConditionLabUsed, env, conditionCode] -> + case compile (beforeConditionLab, env, body) of + [_, env, bodyCode] -> [true, env, singletonBuffer (LABEL (beforeConditionLab)) <+> compileExpr (condition) <+> label (afterConditionLab, afterConditionLabUsed) <+ CJMP ("z", lab) <+> bodyCode <+ JMP (beforeConditionLab)] + esac esac esac | DoWhile (body, condition) -> compile (lab, env, Seq (body, While (condition, body))) diff --git a/src/Stmt.lama b/src/Stmt.lama deleted file mode 100644 index 49d57fbff..000000000 --- a/src/Stmt.lama +++ /dev/null @@ -1,52 +0,0 @@ --- Statement evaluator. - -import State; -import Expr; -import World; - --- Evaluates a statement "stmt" in a configuration "c". --- A configuration is a pair of a state "s" and a world "w". --- Returns a final configuration (if any) --- --- A statement is represented by a data structure of the following shape: --- --- stmt = Assn (string, expr) | --- Seq (stmt, stmt) | --- Skip | --- Read (string) | --- Write (expr) | --- If (expr, stmt, stmt) | --- While (expr, stmt) | --- DoWhile (stmt, expr) - -fun eval (c, stmt) { - var state = c.fst; - var world = c.snd; - - case stmt of - Assn (varName, expr) -> [state <- [varName, evalExpr(state, expr)], world] - | Seq (stmt1, stmt2) -> eval(eval(c, stmt1), stmt2) - | Skip -> c - | Read (varName) -> - case readWorld(world) of - [value, newWorld] -> [state <- [varName, value], newWorld] - esac - | Write (expr) -> [state, writeWorld(evalExpr(state, expr), world)] - | If (condition, body, elsePart) -> - case evalExpr(state, condition) of - 0 -> eval([state, world], elsePart) - | _ -> eval([state, world], body) - esac - | node@While (condition, body) -> - case evalExpr(state, condition) of - 0 -> [state, world] - | _ -> eval(eval([state, world], body), node) - esac - | DoWhile(body, condition) -> eval(eval(c, body), While(condition, body)) - esac -} - --- Evaluates a program with a given input and returns an output -public fun evalStmt (input, stmt) { - eval ([emptyState, createWorld (input)], stmt).snd.getOutput -} diff --git a/src/X86.lama b/src/X86.lama index b60066307..67a7d6703 100644 --- a/src/X86.lama +++ b/src/X86.lama @@ -425,60 +425,54 @@ fun compileBinaryOperation(bop, env, code) { -- Compiles stack machine code into a list of x86 instructions. Takes an environment -- and stack machine code, returns an updated environment and x86 code. fun compile (env, code) { -<<<<<<< HEAD - fun compile (env, code) { - foldl ( - fun ([env, scode], i) { - var code = scode <+ Meta ("# " ++ showSMInsn (i) ++ "\n"); - case i of - READ -> - case env.allocate of - [s, env] -> [env, code <+ Call ("Lread") <+ Mov (eax, s)] - esac - | WRITE -> - case env.pop of - [s, env] -> [env, code <+ Push (s) <+ Call ("Lwrite") <+ Pop (eax)] - esac - | _ -> failure ("codegeneration for instruction %s is not yet implemented\n", i.string) -======= foldl ( fun ([env, scode], i) { var code = scode <+ Meta ("# " ++ showSMInsn (i) ++ "\n"); case i of READ -> case env.allocate of - [s, env] -> [env, code <+> genCallF(env, "Lread", emptyBuffer(), emptyBuffer()) <+ Mov (eax, s)] + [s, env] -> + case env.allocate of + [ecxBackup, env] -> [env.pop [1], code <+> move (ecx, ecxBackup) <+ Call ("Lread") <+> move (ecxBackup, ecx) <+ Mov (eax, s)] + esac esac | WRITE -> case env.pop of - [s, env] -> [env, code <+> genCallF(env, "Lwrite", singletonBuffer(Push(s)), singletonBuffer(Pop (eax)))] + [s, env] -> [env, code <+ Push (s) <+ Call ("Lwrite") <+ Pop (eax)] esac | LD (x) -> case env.addGlobal (x).allocate of - [s, env] -> [env, code <+> move (env.loc (x), s)] - esac + [s, env] -> [env, code <+> move (env.loc (x), s)] + esac + | LDA (x) -> + case env.addGlobal (x).allocate of + [s, env] -> [env, code <+ Lea (env.loc (x), s)] + esac | ST (x) -> case env.addGlobal (x).pop of - [s, env] -> [env, code <+> move (s, env.loc (x))] - esac + [s, env] -> [env, code <+> move (s, env.loc (x))] + esac + | STI -> + case env.pop2 of + [value, addr, env] -> [env.push (addr), code <+> move (value, I (0, addr)) <+> move (value, addr)] + esac + | DROP -> [env.pop [1], code] | BINOP (bop) -> compileBinaryOperation(bop, env, code) | CONST (n) -> case env.allocate of [s, env] -> [env, code <+> move (L (n), s)] esac - | LABEL (lab) -> [env, code <+ Label (lab)] - | JMP (lab) -> [env, code <+ Jmp (lab)] + | LABEL (lab) -> + var msg = if isBarrier(env) then "Barrier at " ++ lab ++ "\n" else "No barrier at " ++ lab ++ "\n" fi; + [if isBarrier(env) then env.retrieveStack (lab) else env fi, code <+ Meta ("# " ++ msg) <+ Label (lab)] + | JMP (lab) -> [env.setStack (lab).setBarrier, code <+ Jmp (lab)] | CJMP (znz, lab) -> case env.pop of - [s, env] -> [env, code <+ Binop ("cmp", L(0), s) <+ CJmp (znz, lab)] + [s, env] -> [env.setStack (lab), code <+ Binop ("cmp", L(0), s) <+ CJmp (znz, lab)] esac | _ -> failure ("codegeneration for instruction %s is not yet implemented\n", i.string) ->>>>>>> 2ad0c4f (Implement control flow compiler) - esac - }, [env, emptyBuffer ()], code) - } - - compile (env, code) + esac + }, [env, emptyBuffer ()], code) } -- A top-level codegeneration function. Takes a driver's environment and a stack machine program,