G-Machine Part3

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

@@ -0,0 +1,69 @@
+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 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/part3/compile.mbt

@@ -0,0 +1,287 @@
+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 {
+    compileE(self, env) + List::of([Update(arity), Unwind])
+  } else {
+    compileE(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)])
+    // start c_constr definition
+    App(App(Constructor(tag = 1, arity = 2), x), xs) => {
+      // Cons(x, xs)
+      compileC(xs, env) + compileC(x, argOffset(1, env)) + List::of([Pack(1, 2)])
+    }
+    // Nil
+    Constructor(tag = 0, arity = 0) => List::of([Pack(0, 0)])
+    // end c_constr definition
+    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 compileE(self : RawExpr[String], env : List[(String, Int)]) -> List[Instruction] {
+  match self {
+    // start num definition
+    Num(n) => List::of([PushInt(n)])
+    // end num definition
+    // start let definition
+    Let(rec, defs, e) => {
+      if rec {
+        compileLetrec(compileE, defs, e, env)
+      } else {
+        compileLet(compileE, defs, e, env)
+      }
+    }
+    // end let definition
+    // start if_and_neg definition
+    App(App(App(Var("if"), b), e1), e2) => {
+      let condition = compileE(b, env)
+      let branch1 = compileE(e1, env)
+      let branch2 = compileE(e2, env)
+      condition +  List::of([Cond(branch1, branch2)])
+    }
+    App(Var("negate"), e) => {
+      compileE(e, env) + List::of([Neg])
+    }
+    // end if_and_neg definition
+    // start binop definition
+    App(App(Var(op), e0), e1) => {
+      match builtinOpS[op] {
+        None => compileC(self, env) + List::of([Eval])
+        Some(instr) => {
+          let code1 = compileE(e1, env)
+          let code0 = compileE(e0, argOffset(1, env))
+          code1 + code0 + List::of([instr])
+        }
+      }
+    }
+    // end binop definition
+    // start e_constr_case definition
+    Case(e, alts) => {
+      compileE(e, env) + List::of([CaseJump(compileAlts(alts, env))])
+    }
+    Constructor(tag = 0, arity = 0) => {
+      // Nil
+      List::of([Pack(0, 0)])
+    }
+    App(App(Constructor(tag = 1, arity = 2), x), xs) => {
+      // Cons(x, xs)
+      compileC(xs, env) + compileC(x, argOffset(1, env)) + List::of([Pack(1, 2)])
+    }
+    // end e_constr_case definition
+    // start default definition
+    _ => compileC(self, env) + List::of([Eval])
+    // end default definition
+  }
+}
+
+fn compileAlts(alts : List[(Int, List[String], RawExpr[String])], env : List[(String, Int)]) -> List[(Int, List[Instruction])] {
+  fn buildenv(variables : List[String], off : Int) -> List[(String, Int)] {
+    match variables {
+      Nil => Nil
+      Cons(v, vs) => {
+        Cons((v, off), buildenv(vs, off + 1))
+      }
+    }
+  }
+  fn go(alts : List[(Int, List[String], RawExpr[String])]) -> List[(Int, List[Instruction])] {
+    match alts {
+      Nil => Nil
+      Cons(alt, rest) => {
+        let (tag, variables, body) = alt
+        let offset = variables.length()
+        let env = buildenv(variables, 0) + argOffset(offset, env)
+        let code = 
+          List::of([Split]) + compileE(body, env) + List::of([Slide(offset)])
+        Cons((tag, code), go(rest))
+      }
+    }
+  }
+  go(alts)
+}
+
+
+fn argOffset(n : Int, env : List[(String, Int)]) -> List[(String, Int)] {
+  env.map(fn { (name, offset) => (name, offset + n) })
+}
+
+
+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())])
+}
+
+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))
+}
+
+
+
+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,
+        ],
+      ),
+    ),
+  ],
+)
+
+// start builtin definition
+let builtinOpS : @hashmap.T[String, Instruction] = {
+  let table  = @hashmap.new(capacity = 50)
+  table["add"] = Add 
+  table["mul"] = Mul
+  table["sub"] = Sub
+  table["div"] = Div
+  table["eq"]  = Eq
+  table["neq"] = Ne
+  table["ge"] = Ge 
+  table["gt"] = Gt
+  table["le"] = Le
+  table["lt"] = Lt
+  table
+}
+// end builtin definition

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

@@ -0,0 +1,30 @@
+// 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])
+  Pack(Int, Int) // tag, arity
+  CaseJump(List[(Int, List[Instruction])])
+  Split
+  Print
+} derive (Eq, Show)
+// end instr definition

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

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