bytecode graph ir

This commit is contained in:
tali 2023-12-23 12:22:36 -05:00
parent d8df7e1eac
commit 31da3529a5
3 changed files with 251 additions and 0 deletions

17
bin/bcgtest.ml Normal file
View File

@ -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);

View File

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

228
lib/compile/bcg.ml Normal file
View File

@ -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