G-Machine Part2

next/sources/gmachine/src/part2/ast.mbt

@@ -0,0 +1,87 @@
+typealias List[E] = @immut/list.T[E]
+
+
+enum RawExpr[T] {
+  Var(T)
+  Num(Int)
+  Constructor(tag~:Int, arity~:Int) // tag, arity
+  App(RawExpr[T], RawExpr[T])
+  Let(Bool, List[(T, RawExpr[T])], RawExpr[T]) // isRec, Defs, Body
+  Case(RawExpr[T], List[(Int, List[T], RawExpr[T])])
+} derive(Show)
+
+struct ScDef[T] {
+  name : String
+  args : List[T]
+  body : RawExpr[T]
+} derive(Show)
+
+fn is_atom[T](self : RawExpr[T]) -> Bool {
+  match self {
+    Var(_) => true
+    Num(_) => true
+    _ => false
+  }
+}
+
+fn binders_of[L, R](l : List[(L, R)]) -> List[L] {
+  fn fst(pair) {
+    let (l, _) = pair
+    return l
+  }
+
+  l.map(fst)
+}
+
+fn rhss_of[L, R](l : List[(L, R)]) -> List[R] {
+  fn snd(pair) {
+    let (_, r) = pair
+    return r
+  }
+
+  l.map(snd)
+}
+
+fn ScDef::new[T](
+  name : String,
+  args : List[T],
+  body : RawExpr[T]
+) -> ScDef[T] {
+  { name : name, args : args, body : body }
+}
+
+let prelude_defs : List[ScDef[String]] = {
+  let args : (FixedArray[String]) -> List[String] = List::of
+  let id = ScDef::new("I", args(["x"]), Var("x")) // id x = x
+  let k = 
+    ScDef::new(
+      "K",
+      args(["x", "y"]),
+      Var("x")
+    ) // K x y = x
+  let k1 = 
+    ScDef::new(
+      "K1",
+      args(["x", "y"]),
+      Var("y")
+    ) // K1 x y = y
+  let s = 
+    ScDef::new(
+      "S",
+      args(["f", "g", "x"]),
+      App(App(Var("f"), Var("x")), App(Var("g"), Var("x")))
+    ) // S f g x = f x (g x)
+  let compose = 
+    ScDef::new(
+      "compose",
+      args(["f", "g", "x"]),
+      App(Var("f"), App(Var("g"), Var("x")))
+    ) // compose f g x = f (g x)
+  let twice = 
+    ScDef::new(
+      "twice",
+      args(["f"]),
+      App(App(Var("compose"), Var("f")), Var("f"))
+    ) // twice f = compose f f
+  List::of([id, k, k1, s, compose, twice])
+}

next/sources/gmachine/src/part2/compile.mbt

@@ -0,0 +1,183 @@
+fn compileSC(self : ScDef[String]) -> (String, Int, List[Instruction]) {
+  let name = self.name
+  let body = self.body
+  let mut arity = 0
+  fn gen_env(i : Int, args : List[String]) -> List[(String, Int)] {
+    match args {
+      Nil => {
+        arity = i
+        return Nil
+      }
+      Cons(s, ss) => Cons((s, i), gen_env(i + 1, ss))
+    }
+  }
+
+  let env = gen_env(0, self.args)
+  (name, arity, compileR(body, env, arity))
+}
+
+
+fn compileR(
+  self : RawExpr[String],
+  env : List[(String, Int)],
+  arity : Int
+) -> List[Instruction] {
+  if arity == 0 {
+    compileC(self, env) + List::of([Update(arity), Unwind])
+  } else {
+    compileC(self, env) + List::of([Update(arity), Pop(arity), Unwind])
+  }
+}
+
+fn compileC(
+  self : RawExpr[String],
+  env : List[(String, Int)]
+) -> List[Instruction] {
+  match self {
+    Var(s) =>
+      match env.lookup(s) {
+        None => List::of([PushGlobal(s)])
+        Some(n) => List::of([Push(n)])
+      }
+    Num(n) => List::of([PushInt(n)])
+    App(e1, e2) =>
+      compileC(e2, env) + compileC(e1, argOffset(1, env)) + List::of([MkApp])
+    Let(rec, defs, e) =>
+      if rec {
+        compileLetrec(compileC, defs, e, env)
+      } else {
+        compileLet(compileC, defs, e, env)
+      }
+    _ => abort("not support yet")
+  }
+}
+
+fn argOffset(n : Int, env : List[(String, Int)]) -> List[(String, Int)] {
+  env.map(fn { (name, offset) => (name, offset + n) })
+}
+
+// start compile_let definition
+fn compileLet(
+  comp : (RawExpr[String], List[(String, Int)]) -> List[Instruction],
+  defs : List[(String, RawExpr[String])],
+  expr : RawExpr[String],
+  env : List[(String, Int)]
+) -> List[Instruction] {
+  let (env, codes) = loop env, List::Nil, defs {
+    env, acc, Nil => (env, acc)
+    env, acc, Cons((name, expr), rest) => {
+      let code = compileC(expr, env)
+      let env = List::Cons((name, 0), argOffset(1, env))
+      continue env, acc + code, rest
+    }
+  }
+  codes + comp(expr, env) + List::of([Slide(defs.length())])
+}
+// end compile_let definition
+
+// start compile_letrec definition
+fn compileLetrec(
+  comp : (RawExpr[String], List[(String, Int)]) -> List[Instruction],
+  defs : List[(String, RawExpr[String])],
+  expr : RawExpr[String],
+  env : List[(String, Int)]
+) -> List[Instruction] {
+  let mut env = env
+  loop defs {
+    Nil => ()
+    Cons((name, _), rest) => {
+      env = Cons((name, 0), argOffset(1, env))
+      continue rest
+    }
+  }
+  let n = defs.length()
+  fn compileDefs(
+    defs : List[(String, RawExpr[String])],
+    offset : Int
+  ) -> List[Instruction] {
+    match defs {
+      Nil => comp(expr, env) + List::of([Slide(n)])
+      Cons((_, expr), rest) =>
+        compileC(expr, env) +
+        Cons(Update(offset), compileDefs(rest, offset - 1))
+    }
+  }
+
+  Cons(Alloc(n), compileDefs(defs, n - 1))
+}
+// end compile_letrec definition
+
+// start prim definition
+let compiled_primitives : List[(String, Int, List[Instruction])] = List::of(
+  [
+    // Arith
+    (
+      "add",
+      2,
+      List::of([Push(1), Eval, Push(1), Eval, Add, Update(2), Pop(2), Unwind]),
+    ),
+    (
+      "sub",
+      2,
+      List::of([Push(1), Eval, Push(1), Eval, Sub, Update(2), Pop(2), Unwind]),
+    ),
+    (
+      "mul",
+      2,
+      List::of([Push(1), Eval, Push(1), Eval, Mul, Update(2), Pop(2), Unwind]),
+    ),
+    (
+      "div",
+      2,
+      List::of([Push(1), Eval, Push(1), Eval, Div, Update(2), Pop(2), Unwind]),
+    ),
+    // Compare
+    (
+      "eq",
+      2,
+      List::of([Push(1), Eval, Push(1), Eval, Eq, Update(2), Pop(2), Unwind]),
+    ),
+    (
+      "neq",
+      2,
+      List::of([Push(1), Eval, Push(1), Eval, Ne, Update(2), Pop(2), Unwind]),
+    ),
+    (
+      "ge",
+      2,
+      List::of([Push(1), Eval, Push(1), Eval, Ge, Update(2), Pop(2), Unwind]),
+    ),
+    (
+      "gt",
+      2,
+      List::of([Push(1), Eval, Push(1), Eval, Gt, Update(2), Pop(2), Unwind]),
+    ),
+    (
+      "le",
+      2,
+      List::of([Push(1), Eval, Push(1), Eval, Le, Update(2), Pop(2), Unwind]),
+    ),
+    (
+      "lt",
+      2,
+      List::of([Push(1), Eval, Push(1), Eval, Lt, Update(2), Pop(2), Unwind]),
+    ),
+    // MISC
+    ("negate", 1, List::of([Push(0), Eval, Neg, Update(1), Pop(1), Unwind])),
+    (
+      "if",
+      3,
+      List::of(
+        [
+          Push(0),
+          Eval,
+          Cond(List::of([Push(1)]), List::of([Push(2)])),
+          Update(3),
+          Pop(3),
+          Unwind,
+        ],
+      ),
+    ),
+  ],
+)
+// end prim definition

next/sources/gmachine/src/part2/instruction.mbt

@@ -0,0 +1,26 @@
+// start instr definition
+enum Instruction {
+  Unwind
+  PushGlobal(String)
+  PushInt(Int)
+  Push(Int)
+  MkApp
+  Slide(Int)
+  Update(Int)
+  Pop(Int)
+  Alloc(Int)
+  Eval
+  Add
+  Sub
+  Mul
+  Div 
+  Neg
+  Eq // ==
+  Ne // !=
+  Lt // <
+  Le // <=
+  Gt // >
+  Ge // >=
+  Cond(List[Instruction], List[Instruction])
+} derive (Eq, Show)
+// end instr definition

next/sources/gmachine/src/part2/moon.pkg.json

@@ -0,0 +1 @@
+{}

next/sources/gmachine/src/part2/programs.mbt

@@ -0,0 +1,41 @@
+let programs : @hashmap.T[String, String] = {
+  let programs = @hashmap.new(capacity=40)
+  programs["square"] =
+    #| (defn square[x] (mul x x))
+  programs["fix"] =
+    #| (defn fix[f] (letrec ([x (f x)]) x))
+  programs["isNil"] =
+    #| (defn isNil[x]
+    #|   (case x [(Nil) 1] [(Cons n m) 0]))
+  programs["tail"] =
+    #| (defn tail[l] (case l [(Cons x xs) xs]))
+  programs["fibs"] =
+    // fibs = 0 : 1 : zipWith (+) fibs (tail fibs)
+    #| (defn fibs[] (Cons 0 (Cons 1 (zipWith add fibs (tail fibs)))))
+  programs["take"] =
+    #| (defn take[n l]
+    #|   (case l
+    #|     [(Nil) Nil]
+    #|     [(Cons x xs)
+    #|        (if (le n 0) Nil (Cons x (take (sub n 1) xs)))]))
+  programs["zipWith"] =
+    #| (defn zipWith[op l1 l2]
+    #|   (case l1
+    #|     [(Nil) Nil]
+    #|     [(Cons x xs)
+    #|       (case l2
+    #|         [(Nil) Nil]
+    #|         [(Cons y ys) (Cons (op x y) (zipWith op xs ys))])]))
+  programs["factorial"] =
+    #| (defn factorial[n]
+    #|   (if (eq n 0) 1 (mul n (factorial (sub n 1)))))
+  programs["abs"] =
+    #| (defn abs[n]
+    #|   (if (lt n 0) (negate n) n))
+  programs["length"] =
+    #| (defn length[l]
+    #|   (case l
+    #|     [(Nil) 0]
+    #|     [(Cons x xs) (add 1 (length xs))]))
+  programs
+}