add comparison instructions and compile some more operators

bin/main.ml

@@ -5,7 +5,7 @@ let[@warning "-26"] () =
   Logs.set_level (Some Logs.Debug);
 
   try
-    let ast = parse "val o = obj { val x = 3 }" in
+    let ast = parse "val ret = 1 + 1 == 2" in
     let prog = compile ast in
     let ret = run prog in
     Fmt.pr "{\"program\":%a,\"output\":%a}" Code.pp_program prog Value.pp ret

lib/compile/bcc.ml

@@ -30,18 +30,25 @@ let compile modl =
             emit_mov ret (Code.cst_of_int slot);
             emit (GET (self, ret));
             Reg ret)
-    | Ast.Binop (op, e1, e2) ->
+    | Ast.Binop (op, lhs, rhs) ->
         let ret = !sp in
-        let lhs = compile_exp env e1 in
+        let lhs = compile_exp env lhs in
-        let rhs = compile_exp env e2 in
+        let rhs = compile_exp env rhs in
         sp := ret + 1;
         emit_mov ret lhs;
-        emit
+        (match op with
-          (match op with
+        | Ast.Add -> emit (ADD (ret, rhs))
-          | Ast.Add -> ADD (ret, rhs)
+        | Ast.Sub -> emit (SUB (ret, rhs))
-          | Ast.Sub -> SUB (ret, rhs)
+        | Ast.Mul -> emit (MUL (ret, rhs))
-          | Ast.Mul -> MUL (ret, rhs)
+        | Ast.Eql -> emit (EQL (ret, rhs))
-          | _ -> Fmt.failwith "Bcc.compile_exp: TODO: %S" (Ast.string_of_binop op));
+        | Ast.Not_eql ->
+            emit (EQL (ret, rhs));
+            emit (NOT ret)
+        | Ast.Lst -> emit (LST (ret, rhs))
+        | Ast.Grt_eql ->
+            emit (LST (ret, rhs));
+            emit (NOT ret)
+        | _ -> Fmt.failwith "Bcc.compile_exp: TODO: %S" (Ast.string_of_binop op));
         Reg ret
     | Ast.Obj body -> compile_obj env body
     | _ -> failwith "Bcc.compile_exp: TODO"

lib/runtime/code.ml

@@ -21,10 +21,14 @@ and ins =
   | ADD of regidx * operand
   | SUB of regidx * operand
   | MUL of regidx * operand
+  | EQL of regidx * operand
+  | LST of regidx * operand
+  | NOT of regidx
   | CON of regidx * Value.vtable
   | GET of regidx * regidx
   | SET of regidx * regidx
   | JMP of basic_block
+  | CBR of operand * basic_block * basic_block
   | RET
 
 let make_basic_block ins_list = { ins_builder = List.rev ins_list; ins_list }
@@ -54,14 +58,15 @@ let frame_size prog =
     | _ -> acc
   in
   let ins acc = function
-    | MOV (r, v) | ADD (r, v) | SUB (r, v) | MUL (r, v) -> op (reg acc r) v
+    | MOV (r, v) | ADD (r, v) | SUB (r, v) | MUL (r, v) | EQL (r, v) | LST (r, v) ->
-    | CON (r, _) -> reg acc r
+        op (reg acc r) v
+    | CON (r, _) | NOT r -> reg acc r
     | GET (o, v) -> reg (reg acc o) v
     | SET (o, v) -> reg (reg acc o) (v + 1)
-    (* | BRT (v, b1, b2) -> *)
+    | CBR (v, b1, b2) ->
-    (*     enqueue b1; *)
+        enqueue b1;
-    (*     enqueue b2; *)
+        enqueue b2;
-    (*     op acc v *)
+        op acc v
     | JMP b ->
         enqueue b;
         acc
@@ -100,22 +105,26 @@ let pp_vtable ppf vt =
     vt.elems;
   Fmt.pf ppf "}"
 
-let pp_ins ~get_bb_name ppf = function
+let pp_ins ~label ppf = function
   | MOV (l, r) -> Fmt.pf ppf "mov %a, %a" pp_reg l pp_operand r
   | ADD (l, r) -> Fmt.pf ppf "add %a, %a" pp_reg l pp_operand r
   | SUB (l, r) -> Fmt.pf ppf "sub %a, %a" pp_reg l pp_operand r
   | MUL (l, r) -> Fmt.pf ppf "mul %a, %a" pp_reg l pp_operand r
+  | EQL (l, r) -> Fmt.pf ppf "eql %a, %a" pp_reg l pp_operand r
+  | LST (l, r) -> Fmt.pf ppf "lst %a, %a" pp_reg l pp_operand r
+  | NOT l -> Fmt.pf ppf "not %a" pp_reg l
   | CON (l, vt) -> Fmt.pf ppf "con %a, %a" pp_reg l pp_vtable vt
   | GET (o, s) -> Fmt.pf ppf "mov %a, %a[%a]" pp_reg s pp_reg o pp_reg s
   | SET (o, s) -> Fmt.pf ppf "mov %a[%a], %a" pp_reg o pp_reg s pp_reg (s + 1)
+  | CBR (v, b1, b2) -> Fmt.pf ppf "cbr %a, %s, %s" pp_operand v (label b1) (label b2)
   | RET -> Fmt.pf ppf "ret"
-  | JMP l -> Fmt.pf ppf "jmp %s" (get_bb_name l)
+  | JMP l -> Fmt.pf ppf "jmp %s" (label l)
 
 let pp_program ppf pr =
   let ep = pr.entrypoint in
   let basic_blocks = ref [ ep, "START" ] in
   let work_list = ref [ ep ] in
-  let get_bb_name bb =
+  let label bb =
     match List.find (fun (bb', _) -> bb == bb') !basic_blocks with
     | _, name -> name
     | exception Not_found ->
@@ -130,11 +139,11 @@ let pp_program ppf pr =
     | bb :: rest ->
         work_list := rest;
         if i > 0 then Fmt.pf ppf ",";
-        Fmt.pf ppf "%S:[" (get_bb_name bb);
+        Fmt.pf ppf "%S:[" (label bb);
         List.iteri
           (fun i is ->
             if i > 0 then Fmt.pf ppf ",";
-            let str = Fmt.str "%a" (pp_ins ~get_bb_name) is in
+            let str = Fmt.str "%a" (pp_ins ~label) is in
             Fmt.pf ppf "%S" str)
           (instructions bb);
         Fmt.pf ppf "]";

lib/runtime/interp.ml

@@ -16,6 +16,22 @@ module Op = struct
     | Value.Int x, Value.Int y -> Value.Int (Int64.mul x y)
     | _, _ -> raise (Runtime_error "cannot mul non integer values")
 
+  let eql v1 v2 =
+    match v1, v2 with
+    | Value.Int x, Value.Int y -> Value.bool (Int64.equal x y)
+    | _, _ -> Value.bool (v1 == v2)
+
+  let lst v1 v2 =
+    match v1, v2 with
+    | Value.Int x, Value.Int y -> Value.bool (Int64.compare x y < 0)
+    | _, _ -> raise (Runtime_error "cannot compare non integer values")
+
+  let truthy = function
+    | Value.False | Value.Nil -> false
+    | _ -> true
+
+  let not v = Value.bool (not (truthy v))
+
   let get o s =
     match o, s with
     | Value.Obj (_, slots), Value.Int i -> slots.(Int64.to_int i)
@@ -52,11 +68,16 @@ let exec fr = function
   | Code.ADD (l, r) -> fr.regs.(l) <- Op.add fr.regs.(l) (eval fr r)
   | Code.SUB (l, r) -> fr.regs.(l) <- Op.add fr.regs.(l) (eval fr r)
   | Code.MUL (l, r) -> fr.regs.(l) <- Op.mul fr.regs.(l) (eval fr r)
+  | Code.EQL (l, r) -> fr.regs.(l) <- Op.eql fr.regs.(l) (eval fr r)
+  | Code.LST (l, r) -> fr.regs.(l) <- Op.lst fr.regs.(l) (eval fr r)
+  | Code.NOT l -> fr.regs.(l) <- Op.not fr.regs.(l)
   | Code.CON (l, vt) -> fr.regs.(l) <- Value.make_obj vt
   | Code.GET (o, s) -> fr.regs.(s) <- Op.get fr.regs.(o) fr.regs.(s)
   | Code.SET (o, s) -> Op.set fr.regs.(o) fr.regs.(s) fr.regs.(s + 1)
   | Code.RET -> fr.pc <- []
   | Code.JMP l -> fr.pc <- Code.instructions l
+  | Code.CBR (v, l1, l2) ->
+      fr.pc <- Code.instructions (if Op.truthy (eval fr v) then l1 else l2)
 
 let rec run fr =
   match fr.pc with

lib/runtime/value.ml

@@ -22,13 +22,12 @@ type t =
   | Int of int64
   | Obj of vtable * t array
 
-let equal v1 v2 =
-  match v1, v2 with
-  | Int x, Int y -> Int64.equal x y
-  | _, _ -> v1 == v2
-
 let make_obj vtable = Obj (vtable, Array.make vtable.n_slots Nil)
 
+let bool = function
+  | true -> True
+  | false -> False
+
 let rec pp ppf = function
   | Obj (vtable, slots) -> pp_obj ppf vtable slots
   | Int n -> Fmt.string ppf (Int64.to_string n)