diff --git a/lectures/control_flow_interpr.pdf b/lectures/control_flow_interpr.pdf new file mode 100644 index 00000000..62c24694 Binary files /dev/null and b/lectures/control_flow_interpr.pdf differ diff --git a/regression/Embedding.meta b/regression/Embedding.meta new file mode 100644 index 00000000..3d52ec9f --- /dev/null +++ b/regression/Embedding.meta @@ -0,0 +1,80 @@ +-- A deep embedding of L0 into Lama +import List; +import Array; +import Fun; +import World; +import Stmt; +import State; +import SM; +import X86; + +-- Embeds expression operands: strings are +-- embedded into identifiers, integer constants --- into +-- constants; non-operand expressions are left intact + +# define HASH # + +fun opnd (x) { + case x of + HASH string -> Var (x) + | HASH unboxed -> Const (x) + | _ -> x + esac +} + +-- Redefinition of standard infix operators +infix + at + (l, r) {Binop ("+", opnd (l), opnd (r))} +infix - at - (l, r) {Binop ("-", opnd (l), opnd (r))} +infix * at * (l, r) {Binop ("*", opnd (l), opnd (r))} +infix / at / (l, r) {Binop ("/", opnd (l), opnd (r))} +infix % at % (l, r) {Binop ("%", opnd (l), opnd (r))} +infix == at == (l, r) {Binop ("==", opnd (l), opnd (r))} +infix != at != (l, r) {Binop ("!=", opnd (l), opnd (r))} +infix < at < (l, r) {Binop ("<", opnd (l), opnd (r))} +infix <= at <= (l, r) {Binop ("<=", opnd (l), opnd (r))} +infix > at > (l, r) {Binop (">", opnd (l), opnd (r))} +infix >= at >= (l, r) {Binop (">=", opnd (l), opnd (r))} +infix && at && (l, r) {Binop ("&&", opnd (l), opnd (r))} +infix !! at !! (l, r) {Binop ("!!", opnd (l), opnd (r))} + +-- Embeds "read" construct; x is expected to be a string (not a "Var") +fun read (x) { + Read (x) +} + +-- Embeds "write" construct; note, e is expression, thus it +-- is embedded using "opnd" +fun write (e) { + Write (opnd (e)) +} + +-- Embeds assignment operator; x is expected to be string, e is expression, this +-- it is embeeded using "opnd" +infix ::= before := (x, e) { + Assn (x, opnd (e)) +} + +-- Embeds sequential composition +infixr >> before ::= (s1, s2) { + Seq (s1, s2) +} + +-- Returns embedded program (thus, the file has to be recompiled as the +-- program changes) +fun program () { + PROGRAM_BODY +} + +case sysargs of + [_] -> printf ("%s\n", compileX86 (compileSM (program ()))) +| _ -> + local input = + reverse (fix (fun (f) {fun (acc) {case readLine () of HASH unboxed -> acc | arg -> f (stringInt (arg) : acc) esac}}) ({})); + + iter (fun (x) {printf ("%d\n", x)}, + case sysargs[1] of + "-i" -> evalStmt (input, program ()) + | "-s" -> evalSM (input, compileSM (program ())) + esac + ) +esac \ No newline at end of file diff --git a/src/Expr.lama b/src/Expr.lama index 7a05379c..9688269a 100644 --- a/src/Expr.lama +++ b/src/Expr.lama @@ -63,8 +63,56 @@ fun evalList (c, exprs) { esac } +fun evalSeq(c, exprs) { + foldl (fun ([c, _], e) { eval (c, e) }, [c, Error], exprs) +} + fun eval (c@[s, w], expr) { - failure ("evalExpr not implemented\n") + case expr of + Assn (tgt, val) -> + case evalList(c, {tgt, val}) of + [[s, w], {Ref (tgt), val}] -> [[s <- [tgt, val], w], val] + esac + | Seq (e1, e2) -> evalSeq (c, {e1, e2}) + | Skip -> [c, Unit] + | Read (id) -> + case readWorld (w) of + [val, w] -> [[s <- [id, val], w], Unit] + esac + | Write (e) -> + case eval (c, e) of + [[s, w], val] -> [[s, writeWorld (val, w)], Unit] + esac + | If (cond, thn, els) -> + case eval (c, cond) of + [c, 0] -> eval (c, els) + | [c, _] -> eval (c, thn) + esac + | whl@While (cond, body) -> + case eval (c, cond) of + [c, 0] -> [c, Unit] + | [c, _] -> + case evalList (c, {body, whl}) of + [c, _] -> [c, Unit] + esac + esac + | rpt@Repeat (body, cond) -> + case evalSeq (c, {body, cond}) of + [c, 0] -> eval (c, rpt) + | [c, _] -> [c, Unit] + esac + | Var (id) -> [c, s (id)] + | Ref (id) -> [c, Ref (id)] + | Const (val) -> [c, val] + | Binop (op, lhs, rhs) -> + case evalList (c, {lhs, rhs}) of + [c, {lhs, rhs}] -> [c, evalOp (op, lhs, rhs)] + esac + | Ignore (e) -> + case eval (c, e) of + [c, _] -> [c, Unit] + esac + esac } diff --git a/src/Parser.lama b/src/Parser.lama index 23ecb02f..a59b7212 100644 --- a/src/Parser.lama +++ b/src/Parser.lama @@ -52,7 +52,15 @@ fun binop (op) { ] } -local primary = memo $ eta syntax ( +local ifNoKw = memo $ eta syntax ( + cond=exp kThen thn=exp els=( + -kElse exp -kFi | + -kElif ifNoKw | + loc=pos kFi {fun (a) { assertVoid(a, Skip, loc) }} + ) {fun (a) { If (cond (Val), thn (a), els (a)) }} +); + +local primary = memo $ eta syntax ( -- decimal constant loc=pos x=decimal {fun (a) {assertValue (a, Const (stringInt (x)), loc)}} | @@ -64,8 +72,17 @@ local primary = memo $ eta syntax ( | _ -> Var (x) esac }} | - $(failure ("the rest of primary parsing in not implemented\n"))), - basic = memo $ eta (expr ({[Right, singleton ([s (":="), + inbr[s("("), exp, s(")")] | + loc=pos kSkip {fun (a) { assertVoid(a, Skip, loc) }} | + loc=pos kRead id=inbr[s("("), lident, s(")")] {fun (a) { assertVoid(a, Read (id), loc) }} | + loc=pos kWrite e=inbr[s("("), exp, s(")")] {fun (a) { assertVoid(a, Write (e (Val)), loc) }} | + -kIf ifNoKw | + loc=pos kWhile cond=exp kDo body=exp kOd {fun (a) { assertVoid(a, While (cond (Val), body (Void)), loc) }} | + loc=pos kFor init=exp s[","] cond=exp s[","] step=exp kDo body=exp kOd + {fun (a) { assertVoid(a, Seq (init (Void), While (cond (Val), Seq (body (Void), step (Void)))), loc) }} | + loc=pos kRepeat body=exp kUntil cond=basic {fun (a) { assertVoid(a, Repeat (body (Void), cond (Val)), loc) }} + ), + basic = memo $ eta (expr ({[Right, singleton ([s (":="), fun (l, loc, r) { fun (a) {assertValue (a, Assn (l (Ref), r (Val)), loc)} }])], @@ -75,8 +92,12 @@ local primary = memo $ eta syntax ( [Left , map (binop, {"+", "-"})], [Left , map (binop, {"*", "/", "%"})] }, - primary)), - exp = memo $ eta syntax (basic | s1=basic s[";"] s2=exp {fun (a) {Seq (s1 (Void), s2 (a))}}); + primary) + ), + 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)}); + +-- Use this for debugging: +-- public parse = syntax (s=exp {local ast = s (Void); printf("AST is:\n%s\n", ast.string); ast}); diff --git a/src/SM.lama b/src/SM.lama index 53311e31..995f8c71 100644 --- a/src/SM.lama +++ b/src/SM.lama @@ -59,8 +59,44 @@ 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, c@[stack, state, w], insns) { + case insns of + {} -> c + | i : is -> + case i of + JMP (l) -> eval (env, c, fromLabel (env, l)) + | CJMP (cond, l) -> + case stack of v : vs -> { + fun isCondTrue (cond, value) { + case cond of + "nz" -> value != 0 + | "z" -> value == 0 + esac + } + eval (env, [vs, state, w], + case isCondTrue(cond, v) of + 0 -> is + | _ -> fromLabel (env, l) + esac + ) + } esac + | _ -> + eval (env, + case i of + CONST (n) -> [n : stack, state, w] + | BINOP (op) -> case stack of v1 : v2 : vs -> [evalOp (op, v1, v2) : vs, state, w] esac + | LD (x) -> [state (x) : stack, state, w] + | ST (x) -> case stack of v : vs -> [vs, state <- [x, v], w] esac + | READ -> case readWorld (w) of [v, w1] -> [v : stack, state, w1] esac + | WRITE -> case stack of v : vs -> [vs, state, writeWorld (v, w)] esac + | LABEL (s) -> c + | LDA (id) -> [Ref (id) : stack, state, w] + | STI -> case stack of v : (Ref (id)) : vs -> [v : vs, state <- [id, v], w] esac + | DROP -> case stack of _ : vs -> [vs, state, w] esac + esac, + is) + esac + esac } -- Runs a stack machine for a given input and a given program, returns an output @@ -102,5 +138,89 @@ fun genLabels (env, n) { -- Takes an expression, returns a list of stack machine -- instructions. public fun compileSM (stmt) { - failure ("compileSM not implemented\n") + fun compileImpl (env, stmt) { + case stmt of + Assn (tgt, e) -> + case compileImpl (env, tgt) of [env, smTgt] -> + case compileImpl (env, e) of [env, smVal] -> + [env, {smTgt, smVal, STI}] + esac + esac + | Seq (e1, e2) -> + case compileImpl (env, e1) of [env, sm1] -> + case compileImpl (env, e2) of [env, sm2] -> + [env, {sm1, sm2}] + esac + esac + | Skip -> [env, {}] + | Read (x) -> [env, {READ, ST (x)}] + | Write (e) -> + case compileImpl (env, e) of [env, sm] -> + [env, {sm, WRITE}] + esac + | If (cond, thn, els) -> + case compileImpl (env, cond) of [env, smCond] -> + case genLabels (env, 2) of [labelEls, labelEnd, env] -> + case compileImpl (env, thn) of [env, smThn] -> + case compileImpl (env, els) of [env, smEls] -> + [env, + { smCond + , CJMP ("z", labelEls) + , smThn + , JMP (labelEnd) + , LABEL (labelEls) + , smEls + , LABEL (labelEnd) + } + ] + esac + esac + esac + esac + | While (cond, body) -> + case compileImpl (env, cond) of [env, smCond] -> + case genLabels (env, 2) of [labelBody, labelCond, env] -> + case compileImpl (env, body) of [env, smBody] -> + [env, + { JMP (labelCond) + , LABEL (labelBody) + , smBody + , LABEL (labelCond) + , smCond + , CJMP ("nz", labelBody) + } + ] + esac + esac + esac + | Repeat (body, cond) -> + case compileImpl (env, cond) of [env, smCond] -> + case genLabels (env, 1) of [labelBody, env] -> + case compileImpl (env, body) of [env, smBody] -> + [env, + { LABEL (labelBody) + , smBody + , smCond + , CJMP ("z", labelBody) + } + ] + esac + esac + esac + | Var (id) -> [env, singleton (LD (id))] + | Ref (id) -> [env, singleton (LDA (id))] + | Const (n) -> [env, singleton (CONST (n))] + | Binop (op, lhs, rhs) -> + case compileImpl (env, lhs) of [env, smLhs] -> + case compileImpl (env, rhs) of [env, smRhs] -> + [env, {smRhs, smLhs, BINOP (op)}] + esac + esac + | Ignore (e) -> + case compileImpl (env, e) of [env, sm] -> + [env, {sm, DROP}] + esac + esac + } + deepFlatten (compileImpl (initCompEnv (), stmt)[1]) } diff --git a/src/Stmt.lama b/src/Stmt.lama new file mode 100644 index 00000000..aa8bf698 --- /dev/null +++ b/src/Stmt.lama @@ -0,0 +1,53 @@ +-- 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) | +-- Repeat (stmt, expr) + +fun eval (c, stmt) { + case c of [s, w] -> + case stmt of + Read (x) -> case readWorld (w) of [v, w1] -> [s <- [x, v], w1] esac + | Write (e) -> [s, writeWorld (evalExpr (s, e), w)] + | Assn (x, e) -> [s <- [x, evalExpr (s, e)], w] + | Seq (s1, s2) -> eval (eval (c, s1), s2) + | Skip -> [s, w] + | If (cond, thn, els) -> case evalExpr (s, cond) of + 0 -> eval (c, els) + | _ -> eval (c, thn) + esac + | whl @ While (cond, body) -> case evalExpr (s, cond) of + 0 -> [s, w] + | _ -> eval (eval (c, body), whl) + esac + | rpt @ Repeat (body, cond) -> { + case eval (c, body) of c1 @ [s1, w1] -> + case evalExpr (s1, cond) of + 0 -> eval (c1, rpt) + | _ -> c1 + esac + esac + } + esac + 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 fd721cd5..f4ccd5ff 100644 --- a/src/X86.lama +++ b/src/X86.lama @@ -363,12 +363,99 @@ fun compile (env, code) { case env.pop of [s, env] -> [env, code <+ Push (s) <+ Call ("Lwrite") <+ Pop (eax)] esac + | CONST (n) -> + case env.allocate of + [s, env] -> [env, code <+ Mov (L (n), s)] + esac + | LD (x) -> + case env.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 + | LABEL (s) -> [if isBarrier (env) then retrieveStack (env, s) else env fi, code <+ Label (s)] + | JMP (l) -> [setBarrier (setStack (env, l)), code <+ Jmp (l)] + | CJMP (c, l) -> + case env.pop of [s, env] -> + [setStack (env, l), code + <+ Binop ("cmp", L (0), s) + <+ CJmp (c, l) + ] + esac + | BINOP (op) -> + case env.pop2 of + [l, r, env] -> + case env.allocate of + [s, env] -> { + + fun oneOf (x, lst) { + case find (fun (v) { compare (x, v) == 0 }, lst) of + Some (_) -> true + | _ -> false + esac + } + + if op.oneOf ({"+", "-", "*"}) then + [env, code + <+ Mov (l, eax) + <+ Binop (op, r, eax) + <+ Mov (eax, s) + ] + elif op.oneOf ({"/", "%"}) then + [env, code + <+ Mov (l, eax) + <+ Cltd + <+ IDiv (r) + <+ Mov (case op of "/" -> eax | "%" -> edx esac, s) + ] + elif op.oneOf ({"==", "!=", "<", "<=", ">", ">="}) then + [env, code + <+ Mov (l, eax) + <+ Binop ("cmp", r, eax) + <+ Mov (L (0), eax) + <+ Set (suffix (op), "%al") + <+ Mov (eax, s) + ] + elif op.oneOf ({"&&", "!!"}) then + [env, code + <+ Mov (L (0), eax) + <+ Binop ("cmp", L (0), l) + <+ Set ("nz", "%al") + <+ Mov (L (0), edx) + <+ Binop ("cmp", L (0), r) + <+ Set ("nz", "%dl") + <+ Binop (op, edx, eax) + <+ Mov (eax, s) + ] + else + failure ("unexpected operator in codegeneration: %s\n", op) + fi + } + esac + esac + | LDA (x) -> + case env.addGlobal(x).allocate of [s, env] -> + [env, code <+ Lea (env.loc (x), s)] + esac + | STI -> + case env.pop of [s, env] -> + case env.peek of ref -> + -- perform an indirect store and reuse the top of the stack to retain the value + [env, code <+> move (s, I (0, ref)) <+> move (s, ref)] + esac + esac + | DROP -> + case env.pop of [_, env] -> + [env, code] + esac | _ -> failure ("codegeneration for instruction %s is not yet implemented\n", i.string) esac }, [env, emptyBuffer ()], code) } - compile (env, code) + compile (env, code) } -- A top-level codegeneration function. Takes a driver's environment and a stack machine program,