bytecode graph ir

bin/bcgtest.ml

@@ -0,0 +1,17 @@
+open Spice.Bcg
+open Spice.Bcg.B.Infix
+
+let () =
+  Logs.set_reporter (Logs.format_reporter ());
+  Logs.set_level (Some Logs.Debug);
+
+  let main =
+    (B.if_ (`R 1)
+       (B.mov (`R 0) (B.int 5))
+       (B.mov (`R 0) (B.int 6))
+    )
+    +> B.mul (`R 0) (B.int 2)
+    |> B.ret (`R 0)
+  in
+
+  Logs.debug (fun m -> dump (m "%s") main);

bin/dune

@@ -9,3 +9,9 @@
  (name bctest)
  (modules bctest)
  (libraries fmt logs))
+
+(executable
+ (public_name spice_bcgtest)
+ (name bcgtest)
+ (modules bcgtest)
+ (libraries spice fmt logs))

lib/compile/bcg.ml

@@ -0,0 +1,228 @@
+module Value = Spice_runtime.Value
+
+(* instruction operand types, etc. *)
+
+type reg = [`R of int]
+type cst = [`Cst of Value.t]
+type arg = [reg | cst]
+type ofs = [reg | `Ofs of int]
+type loc = reg * ofs
+
+type opr = NOT | NEG | ADD | SUB | MUL | DIV | MOD | Cmp of cnd
+and  cnd = EQ | LT | GT (* | NE | LE | GE *)
+
+type vtable =
+    VTABLE
+
+(* instruction types (suffix denotes number of successors) *)
+
+type i0 =
+  | Ret of arg
+
+type i1 =
+  | Mov of reg * arg
+  | Opr of opr * reg * arg
+  | Get of reg * loc
+  | Set of loc * arg
+  | Con of reg * vtable
+  | Loc of reg * reg * string
+  | Cal of reg * loc * reg list
+
+type i2 =
+  | IfT of arg
+  | IfC of cnd * reg * arg
+
+(* bytecode graph nodes *)
+
+type t = {
+  mutable edge : edge;
+  mutable label : string option;
+  mutable preds : int;
+}
+
+and edge =
+  | I0 of i0
+  | I1 of i1 * t
+  | I2 of i2 * t * t
+
+let make edge = {
+  edge;
+  label = None;
+  preds = 0;
+}
+
+(* helper module for constructing and combining bytecode graphs *)
+
+module B = struct
+  type nonrec bcg = t
+  type t = { build : bcg -> bcg } [@@unboxed]
+
+  let empty =
+    {build = Fun.id}
+
+  let append t1 t2 =
+    {build = fun b -> t1.build (t2.build b)}
+
+  let concat ts =
+    let ts_r = List.rev ts in
+    {build = fun b -> List.fold_left (fun b t -> t.build b) b ts_r}
+
+  (* let fix (f : t -> t) : t = *)
+  (*   let _ = f in failwith "TODO: B.fix" *)
+
+  module Infix = struct
+    let ( +> ) = append
+  end
+
+  module Private = struct
+    let i0 (i : i0) (b : t) : bcg =
+      b.build (make (I0 i))
+
+    let i1 (i : i1) : t =
+      {build = fun t -> make (I1 (i, t))}
+
+    let i2 (i : i2) (b1 : t) (b2 : t) : t =
+      {build = fun b -> make (I2 (i, b1.build b, b2.build b))}
+  end
+
+  open Private
+
+  let nil = `Cst Value.Nil
+  let int64 x = `Cst (Value.Int x)
+  let int x = int64 (Int64.of_int x)
+
+  let mov dst src = i1 (Mov (dst, src))
+  let opr op dst src = i1 (Opr (op, dst, src))
+  let get dst loc = i1 (Get (dst, loc))
+  let set loc src = i1 (Set (loc, src))
+  let con dst vtb = i1 (Con (dst, vtb))
+  let loc dst src nam = i1 (Loc (dst, src, nam))
+  let cal dst fn args =
+    (* TODO: check if fn,args well formed *)
+    i1 (Cal (dst, fn, args))
+  let ret v = i0 (Ret v)
+  let if_ = function
+    | #arg as x      -> i2 (IfT x)
+    | `Cmp (c, x, y) -> i2 (IfC (c, x, y))
+
+  let add = opr ADD
+  let sub = opr SUB
+  let mul = opr MUL
+  let div = opr DIV
+  let mod_= opr MOD
+  let not_= opr NOT
+  let neg = opr NEG
+  let ceq = opr (Cmp EQ)
+  let cgt = opr (Cmp GT)
+  let clt = opr (Cmp LT)
+end
+
+(* pretty printer *)
+
+let pp_reg ppf (`R i) =
+  Fmt.pf ppf "R%d" i
+
+let pp_arg ppf = function
+  | #reg as r -> pp_reg ppf r
+  | `Cst v -> Value.pp ppf v
+
+let pp_loc ppf = function
+  | (r, (#reg as i)) -> Fmt.pf ppf "%a[%a]" pp_reg r pp_reg i
+  | (r, `Ofs ofs)    -> Fmt.pf ppf "%a[%d]" pp_reg r ofs
+
+let pp_vtable ppf VTABLE = Fmt.pf ppf "{}"
+
+let string_of_cnd ~prefix = function
+  | EQ -> prefix ^ "eq"
+  | GT -> prefix ^ "gt"
+  | LT -> prefix ^ "lt"
+
+let string_of_opr = function
+  | NOT -> "not"
+  | NEG -> "neg"
+  | ADD -> "add"
+  | SUB -> "sub"
+  | MUL -> "mul"
+  | DIV -> "div"
+  | MOD -> "mod"
+  | Cmp c -> string_of_cnd c ~prefix:"c"
+
+let pp_i0 ppf = function
+  | Ret a -> Fmt.pf ppf "ret %a" pp_arg a
+
+let pp_i1 ppf = function
+  | Mov (a, b) -> Fmt.pf ppf "mov %a, %a" pp_reg a pp_arg b
+  | Opr (o, a, b) -> Fmt.pf ppf "%s %a, %a" (string_of_opr o) pp_reg a pp_arg b
+  | Get (a, b) -> Fmt.pf ppf "mov %a, %a" pp_reg a pp_loc b
+  | Set (a, b) -> Fmt.pf ppf "mov %a, %a" pp_loc a pp_arg b
+  | Loc (a, b, nam) -> Fmt.pf ppf "loc %a, %a.<%s>" pp_reg a pp_reg b nam
+  | Con (a, vtb) -> Fmt.pf ppf "con %a, %a" pp_reg a pp_vtable vtb
+  | Cal (r, f, args) ->
+    Fmt.pf ppf "cal %a, %a(" pp_reg r pp_loc f;
+    List.iteri (fun i a -> if i > 0 then Fmt.pf ppf ","; pp_reg ppf a) args;
+    Fmt.pf ppf ")"
+
+let pp_i2 ppf = function
+  | IfT v -> Fmt.pf ppf "btr %a" pp_arg v
+  | IfC (c, a, b) ->
+    let name = string_of_cnd c ~prefix:"b" in
+    Fmt.pf ppf "%s %a, %a" name pp_reg a pp_arg b
+
+let generate_labels ep =
+  let nl = ref 0 in
+  let rec go t require =
+    t.preds <- t.preds + 1;
+    if t.label = None && (t.preds > 1 || require) then begin
+      t.label <- Some (Fmt.str "L%d" !nl);
+      incr nl
+    end;
+    if t.preds = 1 then begin
+      match t.edge with
+      | I0 _ -> ()
+      | I1 (_, t1) -> go t1 false
+      | I2 (_, t1, t2) -> go t1 false; go t2 true
+    end
+  in
+  ep.label <- Some "EP";
+  go ep false
+
+let dump println ep =
+  let printf ?l fmt =
+    let margin = match l with
+      | None -> ""
+      | Some l -> l ^ ":"
+    in
+    Fmt.kstr println ("%-8s" ^^ fmt) margin
+  in
+
+  let rec pr t =
+    if t.preds = 0 then
+      pr_jmp t
+    else begin
+      t.preds <- 0;
+      match t.edge with
+      | I0 i ->
+        printf ?l:t.label "%a" pp_i0 i
+
+      | I1 (i, t1) ->
+        printf ?l:t.label "%a" pp_i1 i;
+        pr t1
+
+      | I2 (i, t1, t2) ->
+        printf ?l:t.label "%a" pp_i2 i;
+        pr_jmp t2;
+        pr t1;
+        maybe_pr t2
+    end
+
+  and pr_jmp t =
+    printf "jmp %s" (Option.get t.label)
+
+  and maybe_pr t =
+    if t.preds > 0 then
+      pr t
+
+  in
+
+  generate_labels ep;
+  pr ep