Add fmt module, move out some common format helpers, add instruction-selection tracing and make selection use queues rather than list refs.

3 files changed, 136 insertions, 72 deletions

diff --git a/src/boot/be/asm.ml b/src/boot/be/asm.ml
index 10b2142a..4b05e347 100644
--- a/src/boot/be/asm.ml
+++ b/src/boot/be/asm.ml
@@ -62,7 +62,7 @@
 *)
 
 open Common;;
-
+open Fmt;;
 
 let log (sess:Session.sess) =
   Session.log "asm"
@@ -201,6 +201,41 @@ let rec eval64 (e:expr64)
     | EXT e -> Int64.of_int32 (eval32 e)
 ;;
 
+let rec string_of_expr64 (e64:expr64) : string =
+  let bin op a b =
+    Printf.sprintf "(%s %s %s)" (string_of_expr64 a) op (string_of_expr64 b)
+  in
+  let bini op a b =
+    Printf.sprintf "(%s %s %d)" (string_of_expr64 a) op b
+  in
+    match e64 with
+        IMM i when (i64_lt i 0L) -> Printf.sprintf "-0x%Lx" (Int64.neg i)
+      | IMM i -> Printf.sprintf "0x%Lx" i
+      | ADD (a,b) -> bin "+" a b
+      | SUB (a,b) -> bin "-" a b
+      | MUL (a,b) -> bin "*" a b
+      | DIV (a,b) -> bin "/" a b
+      | REM (a,b) -> bin "%" a b
+      | MAX (a,b) ->
+          Printf.sprintf "(max %s %s)"
+            (string_of_expr64 a) (string_of_expr64 b)
+      | ALIGN (a,b) ->
+          Printf.sprintf "(align %s %s)"
+            (string_of_expr64 a) (string_of_expr64 b)
+      | SLL (a,b) -> bini "<<" a b
+      | SLR (a,b) -> bini ">>" a b
+      | SAR (a,b) -> bini ">>>" a b
+      | AND (a,b) -> bin "&" a b
+      | XOR (a,b) -> bin "xor" a b
+      | OR (a,b) -> bin "|" a b
+      | NOT a -> Printf.sprintf "(not %s)" (string_of_expr64 a)
+      | NEG a -> Printf.sprintf "-%s" (string_of_expr64 a)
+      | F_POS f -> Printf.sprintf "<%s>.fpos" f.fixup_name
+      | F_SZ f -> Printf.sprintf "<%s>.fsz" f.fixup_name
+      | M_POS f -> Printf.sprintf "<%s>.mpos" f.fixup_name
+      | M_SZ f -> Printf.sprintf "<%s>.msz" f.fixup_name
+      | EXT _ -> "??ext??"
+;;
 
 type frag =
     MARK  (* MARK == 'PAD (IMM 0L)' *)
@@ -226,6 +261,46 @@ and relaxation =
       relax_choice: int ref; }
 ;;
 
+
+let rec fmt_frag (ff:Format.formatter) (f:frag) : unit =
+  match f with
+    MARK -> fmt ff "MARK"
+  | SEQ fs -> fmt_bracketed_arr_sep "[" "]" ", " fmt_frag ff fs
+  | PAD i -> fmt ff "PAD(%d)" i
+  | BSS i -> fmt ff "BSZ(%Ld)" i
+  | MEMPOS i -> fmt ff "MEMPOS(%Ld)" i
+  | BYTE i -> fmt ff "0x%x" i
+  | BYTES iz ->
+      fmt ff "BYTES";
+      fmt_bracketed_arr_sep "(" ")" ", "
+        (fun ff i -> fmt ff "0x%x" i) ff iz
+  | CHAR c -> fmt ff "CHAR(%s)" (Char.escaped c)
+  | STRING s -> fmt ff "STRING(%s)" (String.escaped s)
+  | ZSTRING s -> fmt ff "ZSTRING(%s)" (String.escaped s)
+  | ULEB128 e -> fmt ff "ULEB128(%s)" (string_of_expr64 e)
+  | SLEB128 e -> fmt ff "SLEB128(%s)" (string_of_expr64 e)
+  | WORD (tm, e) ->
+      fmt ff "%s:%s"
+        (string_of_ty_mach tm) (string_of_expr64 e)
+  | ALIGN_FILE (i, f) ->
+      fmt ff "ALIGN_FILE(%d, " i;
+      fmt_frag ff f;
+      fmt ff ")"
+  | ALIGN_MEM (i, f) ->
+      fmt ff "ALIGN_MEM(%d, " i;
+      fmt_frag ff f;
+      fmt ff ")"
+  | DEF (fix, f) ->
+      fmt ff "DEF(%s, " fix.fixup_name;
+      fmt_frag ff f;
+      fmt ff ")"
+  | RELAX r ->
+      fmt ff "RELAX(";
+      fmt_arr_sep ", " fmt_frag ff r.relax_options
+;;
+
+let sprintf_frag = Fmt.sprintf_fmt fmt_frag;;
+
 exception Relax_more of relaxation;;
 
 let new_relaxation (frags:frag array) =
diff --git a/src/boot/be/il.ml b/src/boot/be/il.ml
index e095e627..b77516b7 100644
--- a/src/boot/be/il.ml
+++ b/src/boot/be/il.ml
@@ -522,54 +522,18 @@ let string_of_reg (f:hreg_formatter) (r:reg) : string =
     | Hreg i -> f i
 ;;
 
-let rec string_of_expr64 (e64:Asm.expr64) : string =
-  let bin op a b =
-    Printf.sprintf "(%s %s %s)" (string_of_expr64 a) op (string_of_expr64 b)
-  in
-  let bini op a b =
-    Printf.sprintf "(%s %s %d)" (string_of_expr64 a) op b
-  in
-    match e64 with
-        Asm.IMM i when (i64_lt i 0L) -> Printf.sprintf "-0x%Lx" (Int64.neg i)
-      | Asm.IMM i -> Printf.sprintf "0x%Lx" i
-      | Asm.ADD (a,b) -> bin "+" a b
-      | Asm.SUB (a,b) -> bin "-" a b
-      | Asm.MUL (a,b) -> bin "*" a b
-      | Asm.DIV (a,b) -> bin "/" a b
-      | Asm.REM (a,b) -> bin "%" a b
-      | Asm.MAX (a,b) ->
-          Printf.sprintf "(max %s %s)"
-            (string_of_expr64 a) (string_of_expr64 b)
-      | Asm.ALIGN (a,b) ->
-          Printf.sprintf "(align %s %s)"
-            (string_of_expr64 a) (string_of_expr64 b)
-      | Asm.SLL (a,b) -> bini "<<" a b
-      | Asm.SLR (a,b) -> bini ">>" a b
-      | Asm.SAR (a,b) -> bini ">>>" a b
-      | Asm.AND (a,b) -> bin "&" a b
-      | Asm.XOR (a,b) -> bin "xor" a b
-      | Asm.OR (a,b) -> bin "|" a b
-      | Asm.NOT a -> Printf.sprintf "(not %s)" (string_of_expr64 a)
-      | Asm.NEG a -> Printf.sprintf "-%s" (string_of_expr64 a)
-      | Asm.F_POS f -> Printf.sprintf "<%s>.fpos" f.fixup_name
-      | Asm.F_SZ f -> Printf.sprintf "<%s>.fsz" f.fixup_name
-      | Asm.M_POS f -> Printf.sprintf "<%s>.mpos" f.fixup_name
-      | Asm.M_SZ f -> Printf.sprintf "<%s>.msz" f.fixup_name
-      | Asm.EXT _ -> "??ext??"
-;;
-
 let string_of_off (e:Asm.expr64 option) : string =
   match e with
       None -> ""
     | Some (Asm.IMM i) when (i64_lt i 0L) ->
         Printf.sprintf " - 0x%Lx" (Int64.neg i)
-    | Some e' -> " + " ^ (string_of_expr64 e')
+    | Some e' -> " + " ^ (Asm.string_of_expr64 e')
 ;;
 
 let string_of_mem (f:hreg_formatter) (a:mem) : string =
   match a with
       Abs e ->
-        Printf.sprintf "[%s]" (string_of_expr64 e)
+        Printf.sprintf "[%s]" (Asm.string_of_expr64 e)
     | RegIn (r, off) ->
         Printf.sprintf "[%s%s]" (string_of_reg f r) (string_of_off off)
     | Spill i ->
@@ -605,9 +569,10 @@ let string_of_operand (f:hreg_formatter) (op:operand) : string =
     | Imm (i, ty) ->
         if !log_iltypes
         then
-          Printf.sprintf "$%s:%s" (string_of_expr64 i) (string_of_ty_mach ty)
+          Printf.sprintf "$%s:%s"
+            (Asm.string_of_expr64 i) (string_of_ty_mach ty)
         else
-          Printf.sprintf "$%s" (string_of_expr64 i)
+          Printf.sprintf "$%s" (Asm.string_of_expr64 i)
 ;;
 
 
diff --git a/src/boot/be/x86.ml b/src/boot/be/x86.ml
index 01b7e299..a1770d06 100644
--- a/src/boot/be/x86.ml
+++ b/src/boot/be/x86.ml
@@ -73,6 +73,19 @@
  *
  *)
 
+
+let log (sess:Session.sess) =
+  Session.log "insn"
+    sess.Session.sess_log_insn
+    sess.Session.sess_log_out
+;;
+
+let iflog (sess:Session.sess) (thunk:(unit -> unit)) : unit =
+  if sess.Session.sess_log_insn
+  then thunk ()
+  else ()
+;;
+
 open Common;;
 
 exception Unrecognized
@@ -2147,44 +2160,55 @@ let new_emitter_without_vregs _ : Il.emitter =
     false None
 ;;
 
-let select_insns (sess:Session.sess) (q:Il.quads) : Asm.frag =
+let select_insns (sess:Session.sess) (qs:Il.quads) : Asm.frag =
   let scopes = Stack.create () in
   let fixups = Stack.create () in
+  let append frag =
+    Queue.add frag (Stack.top scopes)
+  in
   let pop_frags _ =
-    Asm.SEQ (Array.of_list
-               (List.rev
-                  (!(Stack.pop scopes))))
+    Asm.SEQ (queue_to_arr (Stack.pop scopes))
   in
-    ignore (Stack.push (ref []) scopes);
-    for i = 0 to (Array.length q) - 1 do
-      let append frag =
-        let frags = Stack.top scopes in
-          frags := frag :: (!frags)
-      in
-        begin
-          match q.(i).Il.quad_fixup with
-              None -> ()
-            | Some f -> append (Asm.DEF (f, Asm.MARK))
-        end;
-        begin
-          match q.(i).Il.quad_body with
-              Il.Enter f ->
-                Stack.push f fixups;
-                Stack.push (ref []) scopes;
-            | Il.Leave ->
-                append (Asm.DEF (Stack.pop fixups, pop_frags ()))
-            | _ ->
-                try
-                  append (select_insn q.(i))
-                with
+    ignore (Stack.push (Queue.create()) scopes);
+    Array.iteri
+      begin
+        fun i q ->
+          begin
+            match q.Il.quad_fixup with
+                None -> ()
+              | Some f -> append (Asm.DEF (f, Asm.MARK))
+          end;
+          begin
+            let qstr _ = Il.string_of_quad reg_str q in
+              match q.Il.quad_body with
+                  Il.Enter f ->
+                    Stack.push f fixups;
+                    Stack.push (Queue.create()) scopes;
+                | Il.Leave ->
+                    append (Asm.DEF (Stack.pop fixups, pop_frags ()))
+                | _ ->
+                    try
+                      let _ =
+                        iflog sess (fun _ ->
+                                      log sess "quad %d: %s" i (qstr()))
+                      in
+                      let frag = select_insn q in
+                      let _ =
+                        iflog sess (fun _ ->
+                                      log sess "frag %d: %a" i
+                                        Asm.sprintf_frag frag)
+                      in
+                        append frag
+                    with
                     Unrecognized ->
                       Session.fail sess
-                        "E:Assembly error: unrecognized quad: %s\n%!"
-                        (Il.string_of_quad reg_str q.(i));
+                        "E:Assembly error: unrecognized quad %d: %s\n%!"
+                        i (qstr());
                       ()
-        end
-    done;
-    pop_frags()
+          end
+      end
+      qs;
+      pop_frags()
 ;;
 
 let frags_of_emitted_quads (sess:Session.sess) (e:Il.emitter) : Asm.frag =