[ITMO] T05 Svetlana Antoshkina

src/Expr.lama

@@ -63,11 +63,32 @@ fun evalList (c, exprs) {
   esac
 }
 
-fun eval (c@[s, w], expr) {
-  failure ("evalExpr not implemented\n")
+fun eval (c@[st, w], expr) {
+  case expr of
+    Assn (expr1, expr2) -> let [c@[st, w], {Ref (x), v}] = evalList(c, {expr1, expr2}) in [[st <- [x, v], w], v]
+    | Seq (expr1, expr2) -> let [c1, v] = eval(c, expr1) in eval(c1, expr2)
+    | Skip -> [c, 0]
+    | Read (x) -> let [r, w] = readWorld(w) in [[st <- [x, r], w], Void]
+    | Write (e) -> let [c@[st1, w1], v] = eval(c, e) in [[st1, writeWorld(v, w1)], v]
+    | If (cond, expr1, expr2) -> let [c, v] = eval(c, cond) in if v then eval(c, expr1) else eval(c, expr2) fi
+    | While (cond, body) -> 
+      let [c1, n] = eval(c, cond) in 
+      if n != 0
+      then
+        let [c2, _] = eval(c1, body) in
+        eval(c2, While(cond, body))
+      else
+        [c1, 0]
+      fi
+    | DoWhile (cond, body) -> evalList(c, {body, While (cond, body)})
+    | Var (x) -> [c, st(x)]
+    | Ref (x) -> [c, Ref (x)]
+    | Const (n) -> [c, n]
+    | Binop (op, expr1, expr2) -> let [c, {l, r}] = evalList(c, {expr1, expr2}) in [c, evalOp(op, l, r)]
+    | Ignore (expr1) -> let [c, v] = eval(c, expr1) in [c, 0]
+  esac
 }
 
-
 -- Evaluates a program with a given input and returns an output
 public fun evalExpr (input, expr) {
   case eval ([emptyState, createWorld (input)], expr) of

src/Parser.lama

@@ -52,19 +52,39 @@ fun binop (op) {
   ]
 }
 
+--var elseStmt = memo $ eta syntax (
+--  kElif e=exp kThen s1=exp s2=elseStmt {fun (a) {If(e(Val), s1(a), s2(a))}} |
+--  kElse s2=exp kFi {fun (a) {s2(a)}} |
+--  kFi {fun (a) {assertVoid(a, Skip, loc)}}
+--);
+
 var primary  = memo $ eta syntax (
-                                  -- decimal constant
-                                  loc=pos x=decimal                                 {fun (a) {assertValue (a, Const (stringInt (x)), loc)}}     |
+      -- decimal constant
+      loc=pos x=decimal {fun (a) {assertValue (a, Const (stringInt (x)), loc)}} |
 
-                                  -- identifier
-                                  x=lident                                          {fun (a) {
-                                                                                       case a of
-                                                                                         Ref  -> Ref (x)
-                                                                                       | Void -> Ignore (Var (x))
-                                                                                       | _    -> Var (x)
-                                                                                       esac
-                                                                                    }} |
-                                  $(failure ("the rest of primary parsing in not implemented\n"))),
+      -- identifier
+      x=lident {fun (a) {
+                  case a of
+                    Ref  -> Ref (x)
+                  | Void -> Ignore (Var (x))
+                  | _    -> Var (x)
+                  esac
+               }} |
+      inbr[s("("), exp, s(")")] |
+      kSkip {fun (a) {assertVoid(a, Skip, loc)}} |
+      kRead x=inbr[s("("), lident, s(")")] {fun (a) {assertVoid(a, Read (x), loc)}} |
+      kWrite x=inbr[s("("), exp, s(")")] {fun (a) {assertVoid(a, Write (x(Val)), loc)}} |
+      loc=pos kIf e=exp kThen s1=exp s2=elseStmt {fun (a) {If(e(Val), s1(a), s2(a))}} |
+      loc=pos kThen {fun (a) {assertVoid(a, Skip, loc)}} |
+      loc=pos kWhile e=exp kDo s=exp kOd {fun (a) {assertVoid(a, While (e(Val), s(Void)), loc)}} |
+      loc=pos kDo s=exp kWhile e=exp kOd {fun (a) {assertVoid(a, DoWhile(e(Val), s(Void)), loc)}} |
+      loc=pos kFor s1=exp s[","] e=exp s[","] s2=exp kDo s=exp kOd {fun (a) {assertVoid(a, Seq(s1(Void), While (e(Val), Seq(s(Void), s2(Void)))), loc)}}
+    ),
+    elseStmt = memo $ eta syntax (
+      kElif e=exp kThen s1=exp s2=elseStmt {fun (a) {If(e(Val), s1(a), s2(a))}} |
+      kElse s2=exp kFi {fun (a) {s2(a)}} |
+      kFi {fun (a) {assertVoid(a, Skip, loc)}}
+    ),
     basic    = memo $ eta (expr ({[Right, {[s (":="),
                                             fun (l, loc, r) {
                                               fun (a) {assertValue (a, Assn (l (Ref), r (Val)), loc)}

src/SM.lama

@@ -59,8 +59,29 @@ 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, st, w], insns) {
+  case insns of
+     i:rest -> case i of
+        READ      -> let [n, w1] = readWorld(w) in eval(env, [n:stack, st, w1], rest)
+      | WRITE     -> let v:stack1 = stack in eval(env, [stack1, st, writeWorld(v, w)], rest)
+      | BINOP(op) -> let v2:v1:stack1 = stack in eval(env, [evalOp(op, v1, v2):stack1, st, w], rest)
+      | LD(x)     -> eval(env, [st(x):stack, st, w], rest)
+      | LDA(x)    -> eval(env, [Ref(x):stack, st, w], rest)
+      | ST(x)     -> let v:stack1 = stack in eval(env, [v:stack1, st <- [x, v], w], rest)
+      | STI       -> let v:Ref(ref):stack1 = stack in eval(env, [v:stack1, st <-[ref, v], w], rest)
+      | CONST(n)  -> eval(env, [n:stack, st, w], rest)
+      | LABEL (s) -> eval(env, c, rest)
+      | JMP (l)   -> eval(env, c, fromLabel(env, l))
+      | CJMP (c, l) -> 
+        let v:stack1 = stack in
+        case c of
+          "z"  -> if v == 0 then eval(env, [stack1, st, w], fromLabel(env, l)) else eval(env, [stack1, st, w], rest) fi
+        | "nz" -> if v != 0 then eval(env, [stack1, st, w], fromLabel(env, l)) else eval(env, [stack1, st, w], rest) fi
+        esac
+      | DROP      -> let _:stack1 = stack in eval(env, [stack1, st, w], rest)
+      esac
+   | {} -> c
+   esac
 }
 
 -- Runs a stack machine for a given input and a given program, returns an output
@@ -99,6 +120,17 @@ fun genLabels (env, n) {
 }
 
 -- Compiles an expression into a stack machine code.
+-- Takes an expression, returns a list of stack machine instructions
+fun compileExpr (expr) {
+   case expr of
+     Var(x) -> singletonBuffer(LD(x))
+   | Const(n) -> singletonBuffer (CONST(n))
+   | Binop(op, e1, e2) -> compileExpr(e1) <+> compileExpr(e2) <+> singletonBuffer(BINOP(op))
+   esac
+}
+
+-- Compiles a statement into a stack machine code.
+-- Takes a statement, returns a list of stack machine
 -- Takes an expression, returns a list of stack machine
 -- instructions.
 public fun compileSM (stmt) {
@@ -111,10 +143,58 @@ public fun compileSM (stmt) {
 
   fun compile (lab, env, 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))]
+      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))]
+    | Read  (x)      -> [false, env, singletonBuffer (READ) <+ ST (x) <+ DROP]
+    | Write (e)      -> --[false, env, compileExpr (e) <+ WRITE]
+        let [wLab, env] = env.genLabel in
+        let [wLabUsed, env, code] = compile (wLab, env, e) in
+        [false, env, code <+> label (wLab, wLabUsed) <+ WRITE]
+    | Assn  (x, e)   -> --[false, env, compileExpr (e) <+ ST (x)]
+        let [xLab, eLab, env] = env.genLabels(2) in
+        let [xLabUsed, env, xCode] = compile(xLab, env, x) in
+        let [eLabUsed, env, eCode] = compile(eLab, env, e) in
+        [false, env, xCode <+> label(xLab, xLabUsed) <+> eCode <+> label(eLab, eLabUsed) <+ STI]
+    | Seq   (s1, s2) -> 
+        let [s2Lab, env] = env.genLabel in
+        let [s2LabUsed, env, s1Code] = compile (s2Lab, env, s1) in
+        let [labUsed, env, s2Code] = compile (lab, env, s2) in 
+        [labUsed, env, s1Code <+> label (s2Lab, s2LabUsed) <+> s2Code]
+    | If(expr, s1, s2) -> 
+        let [elseLab, env] = env.genLabel in
+        let [_, env, thenBody] = compile (lab, env, s1) in
+        let [_, env, elseBody] = compile (lab, env, s2) in
+          [true, env, 
+            compileExpr(expr) 
+            <+ CJMP ("z", elseLab) 
+            <+> thenBody 
+            <+ JMP (lab) 
+            <+ LABEL (elseLab) 
+            <+> elseBody
+          ]
+    | While(expr, s)  -> 
+        let [condLab, bodyLab, env] = env.genLabels (2) in
+        let [_, env, cond] = compile (condLab, env, s) in
+          [false, env, 
+            singletonBuffer (JMP (condLab))
+            <+ LABEL (bodyLab) 
+            <+> cond
+            <+ LABEL (condLab)  
+            <+> compileExpr (expr)
+            <+ CJMP ("nz", bodyLab)
+          ]
+    | DoWhile(expr, s) -> 
+        compile(lab, env, Seq(s, While(expr, s)))
+    | Binop (op, l, r) -> 
+        let [lLab, rLab, env] = env.genLabels(2) in
+        let [lLabUsed, env, lCode] = compile(lLab, env, l) in
+        let [rLabUsed, env, rCode] = compile(rLab, env, r) in
+        [false, env, lCode <+> label(lLab, lLabUsed) <+> rCode <+> label(rLab, rLabUsed) <+ BINOP(op)]
+    | Ignore(expr)     -> 
+        let [labUsed, env, code] = compile(lab, env, expr) in 
+        [false, env, code <+> label(lab, labUsed) <+ DROP]
     | _                 ->  failure ("compileSM not implemented\n")
     esac
   }

src/Stmt.lama

@@ -10,19 +10,29 @@ 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)             |
+-- 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")
+fun eval (c@[st, w], stmt) {
+   case stmt of
+     Assn(x, e) -> [st <- [x, evalExpr(st, e)], w]
+   | Seq(stmt1, stmt2) -> eval(eval(c, stmt1), stmt2)
+   | Skip -> c
+   | Read(x) -> let [res, w1] = readWorld(w) in [st <- [x, res], w1]
+   | Write(e) -> [st, writeWorld(evalExpr(st, e), w)]
+   | If(e, s1, s2) -> if evalExpr(st, e) != 0 then eval(c, s1) else eval(c, s2) fi
+   | While(e, s) -> if evalExpr(st, e) != 0 then eval(eval(c, s), stmt) else c fi
+   | DoWhile(e, s) -> eval(eval(c, s), While(e, s))
+   esac
 }
 
+
 -- Evaluates a program with a given input and returns an output
 public fun evalStmt (input, stmt) {
   eval ([emptyState, createWorld (input)], stmt).snd.getOutput

src/X86_64.lama

@@ -148,6 +148,24 @@ fun makeEnv (stack, stackSlots, globals, barrier, stackMap) {
     makeEnv (y : stack, stackSlots, globals, barrier, stackMap)
   }
 
+  fun showElemSafe (e) {
+  case e of
+    R(n)    -> sprintf("R(%d)", n)
+  | S(n)    -> sprintf("S(%d)", n)
+  | M(x)    -> sprintf("M(%s)", x)
+  | L(n)    -> sprintf("L(%d)", n)
+  | I(o, x) -> sprintf("I(%d,%s)", o, showElemSafe(x))
+  | _       -> "<unknown>"
+  esac
+}
+
+fun stackToStr (stack) {
+  case stack of
+    {} -> ""
+  | _  -> map(showElemSafe, stack).stringcat(", ")
+  esac
+}
+
   -- Pops one item from the symbolic stack; returns a pair: a popped
   -- item and an updated environment
   fun pop () {
@@ -361,6 +379,37 @@ fun suffix (op) {
   esac
 }
 
+-- Helper function to compile binary operations
+fun compileBinop (op, env, code) {
+  case env.pop2 of 
+    [s1, s2, env] -> case env.allocate of 
+      [s, env] -> [env, 
+        case op of
+          "+" -> code <+ Mov (s2, rax) <+ Binop (op, s1, rax) <+ Mov (rax, s)
+        | "-" -> code <+ Mov (s2, rax) <+ Binop (op, s1, rax) <+ Mov (rax, s)
+        | "*" -> code <+ Mov (s2, rax) <+ Binop (op, s1, rax) <+ Mov (rax, s)
+        | "/" -> code <+ Mov (s2, rax) <+ Cltd <+ IDiv (s1) <+ Mov (rax, s)
+        | "%" -> code <+ Mov (s2, rax) <+ Cltd <+ IDiv (s1) <+ Mov (rdx, s)
+        | "<" -> code <+ Binop ("cmp", s1, s2) <+ Set (suffix(op), "%al") <+ Binop ("&&", L (1), rax) <+ Mov (rax, s)
+        | ">" -> code <+ Binop ("cmp", s1, s2) <+ Set (suffix(op), "%al") <+ Binop ("&&", L (1), rax) <+ Mov (rax, s)
+        | "<=" -> code <+ Binop ("cmp", s1, s2) <+ Set (suffix(op), "%al") <+ Binop ("&&", L (1), rax) <+ Mov (rax, s)
+        | ">=" -> code <+ Binop ("cmp", s1, s2) <+ Set (suffix(op), "%al") <+ Binop ("&&", L (1), rax) <+ Mov (rax, s)
+        | "==" -> code <+ Binop ("cmp", s1, s2) <+ Set (suffix(op), "%al") <+ Binop ("&&", L (1), rax) <+ Mov (rax, s)
+        | "!=" -> code <+ Binop ("cmp", s1, s2) <+ Set (suffix(op), "%al") <+ Binop ("&&", L (1), rax) <+ Mov (rax, s)
+        | "&&" -> code 
+            <+ Mov (L (0), rax) <+ Binop ("cmp", rax, s1) <+ Set ("ne", "%al") <+ Mov (rax, s1)
+            <+ Mov (L (0), rax) <+ Binop ("cmp", rax, s2) <+ Set ("ne", "%al") <+ Mov (rax, s2)
+            <+ Binop ("&&", s1, s2) <+ Mov (s2, s)
+        | "!!" -> code 
+            <+ Mov (L (0), rax) <+ Binop ("cmp", rax, s1) <+ Set ("ne", "%al") <+ Mov (rax, s1)
+            <+ Mov (L (0), rax) <+ Binop ("cmp", rax, s2) <+ Set ("ne", "%al") <+ Mov (rax, s2)
+            <+ Binop ("!!", s1, s2) <+ Mov (s2, s)
+        esac
+      ]
+    esac
+  esac
+}
+
 -- 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) {
@@ -377,6 +426,44 @@ fun compile (env, code) {
           case env.pop of
             [s, env] -> [env, code <+ Mov (s, rdi) <+ Call ("Lwrite")]
           esac
+      | CONST(n) ->
+          case env.allocate of
+            [s, env] -> [env, code <+ Mov (L(n), s)]
+          esac
+      | LD(x) ->
+          let env = env.addGlobal(x)
+          in case env.allocate of
+            [s, env] -> [env, code <+> move(env.loc(x), s)]
+          esac
+      | LDA(x) -> 
+          let env = env.addGlobal(x)
+          in case env.allocate of
+            [s, env] -> [env, code <+ Lea(env.loc(x), s)]
+          esac
+      | ST(x) ->
+          let env = env.addGlobal(x)
+          in case env.pop of
+            [s, env] -> [env.push(s), code <+> move(s, env.loc(x))]
+          esac
+      | STI -> case env.pop2 of
+            [s, ref, env] -> [env.push(s), code <+> move(s, I(0, ref))]
+          esac
+      | BINOP(op) ->
+          compileBinop(op, env, code)
+      | LABEL(l) ->
+          if isBarrier(env) 
+            then [retrieveStack(env, l), code <+ Label(l)]
+            else[env, code <+ Label(l)]
+          fi
+      | JMP(l) ->
+          [setBarrier(setStack(env, l)), code <+ Jmp(l)]
+      | CJMP(c, l) ->
+          case env.pop of
+            [s, env] -> [setBarrier(setStack(env, l)), code <+ Binop("cmp", L(0), s) <+ CJmp(c, l)]
+          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)