From 605698e13b7e8de7efa73f76ae7d9ab2576d19bd Mon Sep 17 00:00:00 2001
From: tali <iitalics@gmail.com>
Date: Sat, 23 Dec 2023 14:35:18 -0500
Subject: [PATCH] pretty print vtables (again)

---
 bin/main.ml         |  2 +-
 lib/runtime/code.ml | 66 +++++++++++++++++++++++++++++++--------------
 2 files changed, 47 insertions(+), 21 deletions(-)

diff --git a/bin/main.ml b/bin/main.ml
index 95daddb..d081774 100644
--- a/bin/main.ml
+++ b/bin/main.ml
@@ -10,7 +10,7 @@ let () =
                 val one = 1
                 fun twice(x) {
                   fun f(x) (x - one) * two
-                  fun g() x + one
+                  fun g() if (x == one) two else (x + one)
                   f(g())
                 }
                 println(twice(4))
diff --git a/lib/runtime/code.ml b/lib/runtime/code.ml
index 8ec4e23..1341d25 100644
--- a/lib/runtime/code.ml
+++ b/lib/runtime/code.ml
@@ -176,18 +176,6 @@ 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 (vtb : Value.vtable) =
-  Fmt.pf ppf "(%d){" vtb.n_slots;
-  let sep = ref "" in
-  Hashtbl.iter
-    (fun name -> function
-       | Value.Method _ -> ()
-       | Value.Field idx ->
-         Fmt.pf ppf "%s%s=%d" !sep name idx;
-         sep := ",")
-    vtb.elems;
-  Fmt.pf ppf "}"
-
 let string_of_cnd ~prefix = function
   | EQ -> prefix ^ "eq"
   | GT -> prefix ^ "gt"
@@ -206,13 +194,23 @@ let string_of_opr = function
 let pp_i0 ppf = function
   | Ret a -> Fmt.pf ppf "ret %a" pp_arg a
 
-let pp_i1 ppf = function
+let pp_i1 ~vtbname 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
+  | Con (a, vtb) ->
+    Fmt.pf ppf "con %a, %s(%d){" pp_reg a (vtbname vtb) vtb.n_slots;
+    let sep = ref "" in
+    Hashtbl.iter
+      (fun name -> function
+         | Value.Method _ -> ()
+         | Value.Field idx ->
+           Fmt.pf ppf "%s%s=%d" !sep name idx;
+           sep := ",")
+      vtb.elems;
+    Fmt.pf ppf "}"
   | 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;
@@ -239,10 +237,20 @@ let generate_labels ep =
       | I2 (_, t1, t2) -> go t1 false; go t2 true
     end
   in
-  ep.label <- Some "EP";
+  (* ep.label <- Some "EP"; *)
   go ep false
 
-let dump ?(margin = 8) println main =
+let dump ?(recursive = true) ?(margin = 8) println main =
+  let vtbnames = ref [] in
+  let vtbqueue = ref [] in
+  let vtbname vtb = try List.assq vtb !vtbnames
+    with Not_found ->
+      let name = Fmt.str "$tb%d" (List.length !vtbnames) in
+      vtbnames := (vtb, name) :: !vtbnames;
+      vtbqueue := !vtbqueue @ [vtb];
+      name
+  in
+
   let printf ?l fmt =
     let prefix = match l with
       | None -> ""
@@ -261,7 +269,7 @@ let dump ?(margin = 8) println main =
         printf ?l:t.label "%a" pp_i0 i
 
       | I1 (i, t1) ->
-        printf ?l:t.label "%a" pp_i1 i;
+        printf ?l:t.label "%a" (pp_i1 ~vtbname) i;
         pr_code t1
 
       | I2 (i, t1, t2) ->
@@ -277,13 +285,31 @@ let dump ?(margin = 8) println main =
   and maybe_pr_code t =
     if t.preds > 0 then
       pr_code t
-
   in
 
   let pr_funct name fn =
     println (Fmt.str "# fun %s(%d)" name fn.n_args);
     generate_labels fn.entry;
-    pr_code fn.entry
+    pr_code fn.entry;
+    println ""
   in
 
-  pr_funct "main" main
+  let pr_vtable (vtb : Value.vtable) =
+    let vnam = vtbname vtb in
+    Hashtbl.iter
+      (fun fnam -> function
+         | Value.Method i ->
+           begin match vtb.mthds.(i) with
+             | Function fn ->
+               pr_funct (Fmt.str "%s.%s" vnam fnam) fn
+             | _ -> ()
+           end
+         | _ -> ())
+      vtb.elems
+  in
+
+  pr_funct "main" main;
+  while recursive && !vtbqueue <> [] do
+    pr_vtable (List.hd !vtbqueue);
+    vtbqueue := List.tl !vtbqueue
+  done