diff --git a/src/Expr.lama b/src/Expr.lama index b758035636..a25615b959 100644 --- a/src/Expr.lama +++ b/src/Expr.lama @@ -1,9 +1,7 @@ -- Expression evaluator - import List; import State; - -- The evaluator itself: takes a state and an expression, -- returns integer value -- @@ -13,6 +11,36 @@ import State; -- Const (int) | -- Binop (string, expr, expr) +public fun showExpr (expr) { + case expr of + Var (x) -> x + | Const (n) -> string (n) + | Binop (op, lhs, rhs) -> sprintf("(%s) %s (%s)", showExpr (lhs), op, showExpr (rhs)) + esac +} + +public fun evalBinop (op, x, y) { + case op of + "+" -> x + y + | "-" -> x - y + | "*" -> x * y + | "/" -> x / y + | "%" -> x % y + | "==" -> x == y + | "!=" -> x != y + | "<" -> x < y + | "<=" -> x <= y + | ">" -> x > y + | ">=" -> x >= y + | "&&" -> x && y + | "!!" -> x !! y + esac +} + public fun evalExpr (st, expr) { - failure ("evalExpr not implemented\n") + case expr of + Var(x) -> st(x) + | Const(n) -> n + | Binop(op, e1, e2) -> evalBinop(op, evalExpr(st, e1), evalExpr(st, e2)) + esac } diff --git a/src/Parser.lama b/src/Parser.lama index 0de3dce168..26e275b560 100644 --- a/src/Parser.lama +++ b/src/Parser.lama @@ -4,7 +4,6 @@ import Ostap; import Lexer; import List; import Fun; -import Matcher; -- A parser of "something" in brackets; l, r are left and right -- brackets as parsers, p --- a parser of "something" @@ -12,14 +11,61 @@ fun inbr (l, p, r) { syntax (-l p -r) } +fun binop (op) {[s (op), fun (x, op, y) {Binop (op, x, y)}]} + +fun binops (ops) {map (binop, ops)} + -- Primary expression var primary = memo $ eta (decimal @ fun (x) {Const (stringInt (x))} | lident @ fun (x) {Var (x)} | inbr (s ("("), exp, s (")"))), - exp = memo $ eta (failure ("expression parsing not implemented\n")); + exp = memo $ eta ( + expr({ + [Left, binops ({"!!", "&&"})], + [Nona, binops ({"==", "!=", "<", ">", "<=", ">="})], + [Left, binops ({"+", "-"})], + [Left, binops ({"*", "/", "%"})] + }, primary) + ); + +-- read, write, skip, assn +var stmt = memo $ eta syntax ( + kIf c=exp kThen t=stmts elifs=elifsP e=maybeElseP kFi {foldr ( + fun (acc, elem) { + let [c, body] = elem in + If (c, body, acc) + }, + e, + {[c, t]} +++ elifs + )} | + kWhile c=exp kDo body=stmts kOd {While (c, body)} | + kDo body=stmts kWhile c=exp kOd {DoWhile (c, body)} | + kFor s1=stmts token[","] e=exp token[","] s2=stmts kDo s3=stmts kOd + {Seq (s1, While (e, Seq (s3, s2)))} | + kRead s["("] x=lident s[")"] {Read (x)} | + kWrite s["("] e=exp s[")"] {Write (e)} | + x=lident s[":="] e=exp {Assn (x, e)} | + kSkip {Skip} +); + +var elifP = memo $ eta syntax ( + s["elif"] c=exp s["then"] body=stmts {[c, body]} +); + +var elifsP = memo $ eta syntax ( + empty {{}} | + b=elifP bb=elifsP {{b} +++ bb} +); + +var maybeElseP = memo $ eta syntax ( + empty {Skip} | + s["else"] body=stmts {body} +); -var stmt = memo $ eta (failure ("statement parsing not implemented\n")); - +var stmts = memo $ eta syntax ( + st=stmt {st} | + st=stmt s[";"] sts=stmts {Seq (st, sts)} +); -- Public top-level parser -public parse = stmt; +public parse = stmts; diff --git a/src/SM.lama b/src/SM.lama index 9c40800506..8b923502c9 100644 --- a/src/SM.lama +++ b/src/SM.lama @@ -13,37 +13,39 @@ import Buffer; -- string representation. public fun showSMInsn (i) { case i of - READ -> sprintf ("READ") - | WRITE -> sprintf ("WRITE") - | BINOP (s) -> sprintf ("BINOP %s", s) - | LD (x) -> sprintf ("LD %s", x) - | ST (x) -> sprintf ("ST %s", x) - | CONST (n) -> sprintf ("CONST %d", n) - | LABEL (s) -> sprintf ("LABEL %s", s) - | JMP (l) -> sprintf ("JMP %s", l) - | CJMP (c, l) -> sprintf ("CJMP %s, %s", c, l) + READ -> sprintf("READ") + | WRITE -> sprintf("WRITE") + | BINOP (s) -> sprintf("BINOP %s", s) + -- load value onto the stack + | LD (x) -> sprintf("LD %s", x) + -- pop from the stack and store popped value + | ST (x) -> sprintf("ST %s", x) + | CONST (n) -> sprintf("CONST %d", n) + | LABEL (l) -> sprintf("LABEL %d", l) + | JMP (l) -> sprintf("JMP %d", l) + | CJMP (c, l) -> sprintf("JMP %s %d", c, l) esac } public fun showSM (prg) { - map (fun (i) {showSMInsn (i) ++ "\n"}, prg).stringcat + map(fun (i) {showSMInsn(i) ++ "\n"}, prg).stringcat } -- Evaluation environment: keeps a mapping between labels and (sub)programs fun initEvalEnv (insns) { var map = fix (fun (rec) { - fun ([m, insns]) { - case insns of - {} -> m - | LABEL (lab) : tl -> rec ([addMap (m, lab, insns), tl]) - | _ : tl -> rec ([m, tl]) - esac - } - }) $ [emptyMap (compare), insns]; + fun ([m, insns]) { + case insns of + {} -> m + | LABEL (lab) : tl -> rec ([addMap (m, lab, insns), tl]) + | _ : tl -> rec ([m, tl]) + esac + } + }) $ [emptyMap (compare), insns]; [fun (l) { - case findMap (map, l) of Some (insns) -> insns esac + case findMap (map, l) of Some (insns) -> insns esac }] } @@ -54,10 +56,36 @@ fun fromLabel (env, lab) { -- Stack machine interpreter. Takes an environment, an SM-configuration and a program, -- returns a final configuration -fun eval (env, c, insns) { - failure ("SM eval not implemented\n") +fun eval (env, [stack, state, world], insns) { + case insns of + {} -> [stack, state, world] + | ins:insns -> case ins of + READ -> let [n, newWorld] = readWorld (world) in + eval (env, [n:stack, state, newWorld], insns) + | WRITE -> let n:newStack = stack in + eval (env, [newStack, state, writeWorld (n, world)], insns) + | BINOP (s) -> let x:y:newStack = stack in + eval (env, [evalBinop (s, x, y) : newStack, state, world], insns) + | LD (s) -> eval (env, [state (s) : stack, state, world], insns) + | ST (s) -> let n:newStack = stack in + eval (env, [newStack, state <- [s, n], world], insns) + | CONST (n) -> eval (env, [n:stack, state, world], insns) + | LABEL (l) -> eval (env, [stack, state, world], insns) + | JMP (l) -> eval (env, [stack, state, world], fromLabel (env, l)) + | CJMP (c, l) -> let n:newStack = stack in + let cv = case c of + "z" -> stack.hd == 0 + | "nz" -> stack.hd != 0 + esac + in + if cv then + eval (env, [newStack, state, world], fromLabel (env, l)) + else + eval (env, [newStack, state, world], insns) + fi + esac + esac } - -- Runs a stack machine for a given input and a given program, returns an output public fun evalSM (input, insns) { eval (initEvalEnv (insns), [{}, emptyState, createWorld (input)], insns)[2].getOutput @@ -66,7 +94,7 @@ public fun evalSM (input, insns) { -- Compilation environment: generates labels fun makeCompEnv (n) { [fun () { - [sprintf ("L%d", n), makeCompEnv (n+1)] + [sprintf ("L%d", n), makeCompEnv (n+1)] }] } @@ -85,8 +113,8 @@ fun genLabels (env, n) { if n == 0 then {env} else case env.genLabel of - [lab, env] -> lab : inner (env, n-1) - esac + [lab, env] -> lab : inner (env, n-1) + esac fi } @@ -94,14 +122,16 @@ fun genLabels (env, n) { } -- Compiles an expression into a stack machine code. --- Takes an expression, returns a list of stack machine instructions +-- Takes an expression, returns a list (of, possibly, lists) +-- of stack machine instructions fun compileExpr (expr) { - failure ("compileExpr not implemented\n") + case expr of + Var(x) -> singletonBuffer (LD (x)) + | Const(n) -> singletonBuffer (CONST (n)) + | Binop(op, e1, e2) -> compileExpr(e2) <+> compileExpr(e1) <+ BINOP (op) + esac } --- Compiles a statement into a stack machine code. --- Takes a statement, returns a list of stack machine --- instructions. public fun compileSM (stmt) { -- Generates a buffer with an optional label -- lab --- the name of the label @@ -114,7 +144,7 @@ public fun compileSM (stmt) { } -- Generates SM code for a given statement - -- lab --- a label th go to after the statement is executed + -- lab --- a label to go to after the statement is executed -- env --- compilation environment -- stmt --- a statement to generate SM code for -- Returns a triple: @@ -123,28 +153,40 @@ public fun compileSM (stmt) { -- code buffer 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 ()] + | 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) -> case env.genLabel of [s2Lab, env] -> - case compile (s2Lab, env, s1) of - [s2LabUsed, env, s1Code] -> - case compile (lab, env, s2) of - [labUsed, env, s2Code] -> [labUsed, env, s1Code <+> label (s2Lab, s2LabUsed) <+> s2Code] - esac - esac + case compile (s2Lab, env, s1) of + [s2LabUsed, env, s1Code] -> + case compile (lab, env, s2) of + [labUsed, env, s2Code] -> [labUsed, env, s1Code <+> label (s2Lab, s2LabUsed) <+> s2Code] + esac + esac esac - | _ -> failure ("compileSM not implemented\n") + | If (c, t, e) -> + let [flab, env] = env.genLabel in + let [_, env, tcode] = compile (lab, env, t) in + let [_, env, fcode] = compile (lab, env, e) in + [true, env, compileExpr (c) <+ CJMP ("z", flab) <+> tcode <+ JMP (lab) <+ LABEL (flab) <+> fcode] + | While (c, body) -> + let [clab, env] = env.genLabel in + let [_, env, bcode] = compile (clab, env, body) in + [true, env, label (clab, true) <+> compileExpr (c) <+ CJMP ("z", lab) <+> bcode <+ JMP (clab)] + | DoWhile (c, body) -> + let [clab, env] = env.genLabel in + let [_, env, bcode] = compile (clab, env, body) in + [false, env, label (clab, true) <+> bcode <+> compileExpr (c) <+ CJMP ("nz", clab)] esac } case initCompEnv ().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, _, code] -> getBuffer $ code <+> label (endLab, endLabUsed) + esac esac } diff --git a/src/Stmt.lama b/src/Stmt.lama index 8b94e3bfc3..95416c1269 100644 --- a/src/Stmt.lama +++ b/src/Stmt.lama @@ -1,5 +1,4 @@ -- Statement evaluator. - import State; import Expr; import World; @@ -10,20 +9,46 @@ import World; -- -- 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) | +-- 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) { - failure ("Stmt eval not implemented\n") +public fun showStmt (stmt) { + case stmt of + Assn (x, e) -> x ++ " := " ++ showExpr (e) + | Seq (s, ss) -> showStmt (s) ++ ";\n" ++ showStmt (ss) + | Skip -> "skip" + | Read (x) -> sprintf ("read(%s)", x) + | Write (e) -> sprintf ("write(%s)", showExpr (e)) + | If (c, t, e) -> sprintf ("if %s then\n%s else\n%s\nfi", showExpr (c), showStmt (t), showStmt (e)) + | While (c, b) -> sprintf ("while %s do\n%s\nod", showExpr (c), showStmt (b)) + | DoWhile (c, b) -> sprintf ("do\n%s\nwhile %s od", showStmt (b), showExpr (c)) + esac } +fun eval ([st, world], stmt) { + case stmt of + Assn (x, e) -> [st <- [x, evalExpr(st, e)], world] + | Seq (stmt1, stmt2) -> eval(eval([st, world], stmt1), stmt2) + | Skip -> [st, world] + | Read (x) -> let [v, newWorld] = readWorld(world) in [st <- [x, v], newWorld] + | Write (e) -> [st, writeWorld(evalExpr(st, e), world)] + | If (c, t, e) -> case evalExpr (st, c) of + 0 -> eval ([st, world], e) + | _ -> eval ([st, world], t) + esac + | While (c, b) -> case evalExpr (st, c) of + 0 -> [st, world] + | _ -> eval ([st, world], Seq (b, While (c, b))) + esac + | DoWhile (c, b) -> eval ([st, world], Seq (b, While (c, b))) + esac +} -- Evaluates a program with a given input and returns an output public fun evalStmt (input, stmt) { - eval ([emptyState, createWorld (input)], stmt).snd.getOutput + eval([emptyState, createWorld(input)], stmt).snd.getOutput } diff --git a/src/X86.lama b/src/X86.lama index d8776316d7..076d8d2143 100644 --- a/src/X86.lama +++ b/src/X86.lama @@ -314,9 +314,18 @@ fun compile (env, code) { case env.pop of [s, env] -> [env, code <+> genCallF(env, "Lwrite", singletonBuffer(Push(s)), singletonBuffer(Pop (eax)))] esac - | _ -> failure ("codegeneration for instruction %s is not yet implemented\n", i.string) - esac - }, [env, emptyBuffer ()], code)} + | LD (x) -> + case env.addGlobal (x).allocate of + [s, env] -> [env, code <+> move (env.loc (x), s)] + esac + | ST (x) -> + case env.addGlobal (x).pop of + [s, env] -> [env, code <+> move (s, env.loc (x))] + esac + | _ -> failure ("instruction %s is not recognized\n", i.string) + esac + }, [env, emptyBuffer ()], code) +} -- A top-level codegeneration function. Takes a driver's environment and a stack machine program, -- compiles the program into machine code, and compiles the machine code into an executable @@ -325,8 +334,8 @@ public fun compileX86 (args, code) { [env, code] -> var asmFile = args.getBaseName ++ ".s", runtime = case getEnv ("LAMA_RUNTIME") of - #val -> "../runtime/" - | path -> path + #val -> "../runtime/" + | path -> path esac ++ "/runtime.o"; fwrite (asmFile, @@ -339,8 +348,8 @@ public fun compileX86 (args, code) { prologue (getStackSize (env)) <+> code <+> epilogue () - ) - ).stringcat); + ) + ).stringcat); system ({"gcc -g -m32 -o ", args.getBaseName, " ", runtime, " ", asmFile}.stringcat) esac diff --git a/src/X86_64.lama b/src/X86_64.lama index ac8e84d03c..b7934c47f4 100644 --- a/src/X86_64.lama +++ b/src/X86_64.lama @@ -94,6 +94,7 @@ fun insnString (insn) { | IDiv (s1) -> sprintf ("\tidivq\t%s\n", opndString (s1)) | Binop (op, s1, s2) -> sprintf ("\t%s\t%s,\t%s\n", binopString (op), opndString (s1), opndString (s2)) | Mov (s1, s2) -> sprintf ("\tmovq\t%s,\t%s\n", opndString (s1), opndString (s2)) + | Movzb (s1, s2) -> sprintf ("\tmovzbq\t%s,\t%s\n", s1, opndString (s2)) | Push (s) -> sprintf ("\tpushq\t%s\n", opndString (s)) | Pop (s) -> sprintf ("\tpopq\t%s\n", opndString (s)) | Ret -> "\tret\n" @@ -136,6 +137,17 @@ fun makeEnv (stack, stackSlots, globals) { of [x, n] -> [x, makeEnv (x : stack, if n > stackSlots then n else stackSlots fi, globals)]esac } + fun deallocate (x) { + case x of + S (n) : _ -> if n == stackSlots then + [singletonBuffer (Pop (rax)), makeEnv (stack, stackSlots - 1, globals)] + else + [emptyBuffer (), makeEnv (stack, stackSlots, globals)] + fi + | _ -> [emptyBuffer (), makeEnv (stack, stackSlots, globals)] + esac + } + -- Pushes an item on the symbolic state; returns an updated envirtonment fun push (y) { makeEnv (y : stack, stackSlots, globals) @@ -177,7 +189,7 @@ fun makeEnv (stack, stackSlots, globals) { stackSlots } - [envString, allocate, push, pop, pop2, addGlobal, loc, getGlobals, getStackSize] + [envString, allocate, push, pop, pop2, addGlobal, loc, getGlobals, getStackSize, deallocate] } -- Exported accessors @@ -217,6 +229,10 @@ fun getStackSize (env) { env [8] () } +fun deallocate (env, x) { + env [9] (x) +} + -- Creates an initial environment fun initEnv () { makeEnv ({}, 0, emptySet (compare)) @@ -292,6 +308,53 @@ fun suffix (op) { esac } +fun contains (l, el) { + fun eq (other) { compare (other, el) == 0 } + + compare (find (eq, l), None) +} + +fun compileBinop (op, x, y, res) { + fun compileSimple (op, x, y, res) { + if memOpnd(x) && memOpnd(y) then + singletonBuffer(Mov(y, rax)) <+ Binop(op, x, rax) <+ Mov(rax, res) + else + singletonBuffer(Binop(op, x, y)) <+ Mov(y, res) + fi + } + + fun compileDiv (op, x, y, res) { + let out = case op of + "/" -> rax + | "%" -> rdx + esac in singletonBuffer (Mov (y, rax)) <+ Cqo <+ IDiv (x) <+ Mov (out, res) + } + + fun compileLog (op, x, y, res) { + fun toBool (s) { + singletonBuffer (Binop ("cmp", L (0), s)) <+ Set ("nz", "%al") <+ Binop("&&", L(1), rax) <+ Mov(rax, s) + } + + toBool (x) <+> toBool (y) <+> compileSimple (op, x, y, res) + } + + fun compileCmp (op, x, y, res) { + let compare = if memOpnd(x) && memOpnd(y) then + singletonBuffer (Mov (y, rax)) <+ Binop ("cmp", x, rax) + else + singletonBuffer (Binop ("cmp", x, y)) + fi + in compare <+ Set (suffix (op), "%al") <+ Binop("&&", L(1), rax) <+ Mov(rax, res) + } + + if {"+", "-", "*"}.contains (op) then compileSimple (op, x, y, res) + elif {"/", "%"}.contains (op) then compileDiv (op, x, y, res) + elif {"!!", "&&"}.contains (op) then compileLog (op, x, y, res) + elif {"==", "!=", "<=", "<", ">=", ">"}.contains (op) then compileCmp (op, x, y, res) + else failure("coegeneration for binary operation %s is not yet implemented", op) + fi +} + -- 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) { @@ -307,6 +370,30 @@ fun compile (env, code) { case env.pop of [s, env] -> [env, code <+ Mov (s, rdi) <+ Call ("Lwrite")] esac + | LD (x) -> + case env.allocate of + [s, env] -> [env, code <+> move (env.loc (x), s)] + esac + | ST (x) -> + let [s, env] = env.addGlobal (x).pop in + let [dcode, env] = env.deallocate (s) in + [env, code <+> move (s, env.loc (x)) <+> dcode] + | BINOP (op) -> + let [y, x, env] = env.pop2 in + let [res, env] = env.allocate in + let [xdcode, env] = env.deallocate (x) in + let [ydcode, env] = env.deallocate (y) in + [env, code <+> compileBinop (op, x, y, res) <+> xdcode <+> ydcode] + | CONST (n) -> + case env.allocate of + [s, env] -> [env, code <+ Mov (L (n), s)] + esac + | LABEL (l) -> [env, code <+ Label (l)] + | JMP (l) -> [env, code <+ Jmp (l)] + | CJMP (c, l)-> + case env.pop of + [s, env] -> [env, code <+ Binop ("cmp", L (0), s) <+ CJmp (c, l)] + esac | _ -> failure ("codegeneration for instruction %s is not yet implemented\n", i.string) esac }, [env, emptyBuffer ()], code)