Skip to content

Commit

Permalink
Implement control flow compiler
Browse files Browse the repository at this point in the history
  • Loading branch information
@Stepavly
Stepavly committed Aug 14, 2024
1 parent 40b8b71 commit 755b349
Show file tree
Hide file tree
Showing 4 changed files with 348 additions and 46 deletions.
90 changes: 71 additions & 19 deletions src/Expr.lama
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@
import List;
import State;
import World;
-- import Utils;

-- As association map which maps "\otimes" into "\oplus"
var ops = {
Expand All @@ -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
}

Expand All @@ -49,25 +62,64 @@ public fun evalOp (op, l, r) {
-- Binop (string, expr, expr) |
-- Ignore (expr)

-- Evaluates a list of expressions, properly threading a configurations.
-- Returns the final configuration and the list of values
fun evalList (c, exprs) {
case foldl (fun ([c, vals], e) {
case eval (c, e) of
[c, v] -> [c, v : vals]
esac
},
[c, {}],
exprs) of
[c, vals] -> [c, reverse (vals)]
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
}

fun eval (c@[s, w], expr) {
failure ("evalExpr not implemented\n")
}


-- Evaluates a program with a given input and returns an output
public fun evalExpr (input, expr) {
case eval ([emptyState, createWorld (input)], expr) of
Expand Down
14 changes: 13 additions & 1 deletion src/Parser.lama
View file
Original file line number Diff line number Diff line change
Expand Up @@ -53,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)}} |

Expand All @@ -64,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)}
Expand All @@ -76,6 +84,10 @@ 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
Expand Down
148 changes: 141 additions & 7 deletions src/SM.lama
View file
Original file line number Diff line number Diff line change
Expand Up @@ -57,10 +57,58 @@ fun fromLabel (env, lab) {
env [0] (lab)
}

fun compileCJmp(znz, lab, env, [(x:t), state, world]) {
case znz of
("z") -> if x then [None, [t, state, world]] else [Some (env.fromLabel (lab)), [t, state, world]] fi
| ("nz") -> if x then [Some (env.fromLabel (lab)), [t, state, world]] else [None, [t, state, world]] fi
esac
}

fun evalSingle (env, conf@[stack, state, world], instruction) {
case instruction of
READ ->
case readWorld(world) of
[value, newWorld] -> [None, [value:stack, state, newWorld]]
esac
| WRITE ->
[None, [tl(stack), state, writeWorld(hd(stack), world)]]
| BINOP (bop) ->
case stack of
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]
| JMP (lab) -> [Some (env.fromLabel (lab)), conf]
| CJMP (znz, lab) -> compileCJmp (znz, lab, env, conf)
esac
}

-- 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")
case insns of
{} -> c
| ins:insns ->
case evalSingle(env, c, ins) of
[None, conf] -> eval(env, conf, insns)
| [Some (insns), conf] -> eval(env, conf, insns)
esac
esac
}

-- Runs a stack machine for a given input and a given program, returns an output
Expand Down Expand Up @@ -99,7 +147,17 @@ fun genLabels (env, n) {
}

-- Compiles an expression into a stack machine code.
-- Takes an expression, returns a list of stack machine
-- Takes an expression, returns a list of stack machine instructions
fun compileExpr (expr) {
case expr of
Var (varName) -> singletonBuffer (LD (varName))
| Const (num) -> singletonBuffer (CONST (num))
| Binop (bop, left, right) -> compileExpr(left) <+> compileExpr(right) <+ BINOP (bop)
esac
}

-- Compiles a statement into a stack machine code.
-- Takes a statement, returns a list of stack machine
-- instructions.
public fun compileSM (stmt) {
fun label (lab, labUsed) {
Expand All @@ -111,11 +169,87 @@ 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))]
| _ -> failure ("compileSM not implemented\n")
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
[s2LabUsed, env, s1Code] ->
case compile (lab, env, s2) of
[labUsed, env, s2Code] -> [labUsed, env, s1Code <+> label (s2Lab, s2LabUsed) <+> s2Code]
esac
esac
esac
| If (condition, ifBranch, elseBranch) ->
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 (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)))
esac
}

Expand Down
Loading

0 comments on commit 755b349

Please sign in to comment.