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

6 files changed, 40 insertions, 40 deletions

diff --git a/src/boot/me/dwarf.ml b/src/boot/me/dwarf.ml
index 9423d4ee..56b66f70 100644
--- a/src/boot/me/dwarf.ml
+++ b/src/boot/me/dwarf.ml
@@ -1428,7 +1428,7 @@ let dwarf_visitor
       | Il.Bits64 -> TY_i64
   in
 
-  let path_name _ = Ast.fmt_to_str Ast.fmt_name (Walk.path_to_name path) in
+  let path_name _ = Fmt.fmt_to_str Ast.fmt_name (Walk.path_to_name path) in
 
   let (abbrev_table:(abbrev, int) Hashtbl.t) = Hashtbl.create 0 in
 
@@ -2496,29 +2496,29 @@ let fmt_dies
     : unit =
   let ((root:int),(dies:(int,die) Hashtbl.t)) = dies in
   let rec fmt_die die =
-    Ast.fmt ff "@\nDIE <0x%x> %s" die.die_off (dw_tag_to_string die.die_tag);
+    Fmt.fmt ff "@\nDIE <0x%x> %s" die.die_off (dw_tag_to_string die.die_tag);
     Array.iter
       begin
         fun (at,(form,data)) ->
-          Ast.fmt ff "@\n  %s = " (dw_at_to_string at);
+          Fmt.fmt ff "@\n  %s = " (dw_at_to_string at);
           begin
             match data with
-                DATA_num n -> Ast.fmt ff "0x%x"  n
-              | DATA_str s -> Ast.fmt ff "\"%s\"" s
-              | DATA_other -> Ast.fmt ff "<other>"
+                DATA_num n -> Fmt.fmt ff "0x%x"  n
+              | DATA_str s -> Fmt.fmt ff "\"%s\"" s
+              | DATA_other -> Fmt.fmt ff "<other>"
           end;
-          Ast.fmt ff "  (%s)" (dw_form_to_string form)
+          Fmt.fmt ff "  (%s)" (dw_form_to_string form)
       end
       die.die_attrs;
     if (Array.length die.die_children) != 0
     then
       begin
-        Ast.fmt ff "@\n";
-        Ast.fmt_obox ff;
-        Ast.fmt ff "  children: ";
-        Ast.fmt_obr ff;
+        Fmt.fmt ff "@\n";
+        Fmt.fmt_obox ff;
+        Fmt.fmt ff "  children: ";
+        Fmt.fmt_obr ff;
         Array.iter fmt_die die.die_children;
-        Ast.fmt_cbb ff
+        Fmt.fmt_cbb ff
       end;
   in
     fmt_die (Hashtbl.find dies root)
@@ -2613,7 +2613,7 @@ let read_dies
       begin
         fun _ ->
           log sess "read DIEs:";
-          log sess "%s" (Ast.fmt_to_str fmt_dies (root, all_dies));
+          log sess "%s" (Fmt.fmt_to_str fmt_dies (root, all_dies));
       end;
     (root, all_dies)
 ;;
diff --git a/src/boot/me/resolve.ml b/src/boot/me/resolve.ml
index bfbac10d..2c718778 100644
--- a/src/boot/me/resolve.ml
+++ b/src/boot/me/resolve.ml
@@ -445,9 +445,9 @@ and lookup_type_by_name
                 log cx "applying %d type args to %d params"
                   (Array.length args) (Array.length params);
                 log cx "params: %s"
-                  (Ast.fmt_to_str Ast.fmt_decl_params params);
+                  (Fmt.fmt_to_str Ast.fmt_decl_params params);
                 log cx "args: %s"
-                  (Ast.fmt_to_str Ast.fmt_app_args args);
+                  (Fmt.fmt_to_str Ast.fmt_app_args args);
             end;
           let ty = rebuild_ty_under_params ty params args true in
             iflog cx (fun _ -> log cx "--- lookup_type_by_name %a ==> %a"
@@ -538,7 +538,7 @@ let type_resolving_visitor
       log cx "collected resolved slot #%d with type %s" (int_of_node slot.id)
         (match slot.node.Ast.slot_ty with
              None -> "??"
-           | Some t -> (Ast.fmt_to_str Ast.fmt_ty t));
+           | Some t -> (Fmt.fmt_to_str Ast.fmt_ty t));
       inner.Walk.visit_slot_identified_pre slot
   in
 
diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml
index f7acccfb..d33eb6d9 100644
--- a/src/boot/me/semant.ml
+++ b/src/boot/me/semant.ml
@@ -65,7 +65,7 @@ type file_code = (node_id, item_code) Hashtbl.t;;
 type data_frags = (data, (fixup * Asm.frag)) Hashtbl.t;;
 
 let string_of_name (n:Ast.name) : string =
-  Ast.fmt_to_str Ast.fmt_name n
+  Fmt.fmt_to_str Ast.fmt_name n
 ;;
 
 (* The only need for a carg is to uniquely identify a constraint-arg
diff --git a/src/boot/me/trans.ml b/src/boot/me/trans.ml
index a7ff502c..7cb77e0c 100644
--- a/src/boot/me/trans.ml
+++ b/src/boot/me/trans.ml
@@ -812,7 +812,7 @@ let trans_visitor
                                         (Printf.sprintf
                                            "access outer frame slot #%d = %s"
                                            (int_of_node slot_id)
-                                           (Ast.fmt_to_str
+                                           (Fmt.fmt_to_str
                                               Ast.fmt_slot_key k))
                                 end
                             in
@@ -1214,7 +1214,7 @@ let trans_visitor
     iflog
       begin
         fun _ ->
-          annotate (Ast.fmt_to_str Ast.fmt_atom atom)
+          annotate (Fmt.fmt_to_str Ast.fmt_atom atom)
       end;
 
     match atom with
@@ -1788,7 +1788,7 @@ let trans_visitor
       iflog
         begin
           fun _ ->
-            annotate ((Ast.fmt_to_str Ast.fmt_expr expr) ^
+            annotate ((Fmt.fmt_to_str Ast.fmt_expr expr) ^
                         ": cond, finale")
         end
     in
@@ -1875,7 +1875,7 @@ let trans_visitor
       iflog
         begin
           fun _ ->
-            annotate ((Ast.fmt_to_str Ast.fmt_expr expr) ^
+            annotate ((Fmt.fmt_to_str Ast.fmt_expr expr) ^
                         ": plain exit, finale")
         end
     in
@@ -2037,7 +2037,7 @@ let trans_visitor
 
   and trans_check_expr (e:Ast.expr) : unit =
     let fwd_jmps = trans_cond false e in
-      trans_cond_fail (Ast.fmt_to_str Ast.fmt_expr e) fwd_jmps
+      trans_cond_fail (Fmt.fmt_to_str Ast.fmt_expr e) fwd_jmps
 
   and trans_malloc (dst:Il.cell) (nbytes:Il.operand) : unit =
     trans_upcall "upcall_malloc" dst [| nbytes |]
@@ -2489,7 +2489,7 @@ let trans_visitor
       : unit =
     iflog (fun _ ->
              annotate ("copy_ty: referent data of type " ^
-                         (Ast.fmt_to_str Ast.fmt_ty ty)));
+                         (Fmt.fmt_to_str Ast.fmt_ty ty)));
     match ty with
         Ast.TY_nil
       | Ast.TY_bool
@@ -2626,7 +2626,7 @@ let trans_visitor
         | MEM_interior when type_is_structured ty ->
             (iflog (fun _ ->
                       annotate ("mark interior slot " ^
-                                  (Ast.fmt_to_str Ast.fmt_slot slot))));
+                                  (Fmt.fmt_to_str Ast.fmt_slot slot))));
             let (mem, _) = need_mem_cell cell in
             let tmp = next_vreg_cell Il.voidptr_t in
             let ty = maybe_iso curr_iso ty in
@@ -2750,7 +2750,7 @@ let trans_visitor
         | MEM_interior when type_is_structured ty ->
             (iflog (fun _ ->
                       annotate ("drop interior slot " ^
-                                  (Ast.fmt_to_str Ast.fmt_slot slot))));
+                                  (Fmt.fmt_to_str Ast.fmt_slot slot))));
             let (mem, _) = need_mem_cell cell in
             let vr = next_vreg_cell Il.voidptr_t in
               lea vr mem;
@@ -2767,7 +2767,7 @@ let trans_visitor
     if cx.ctxt_sess.Session.sess_trace_drop ||
       cx.ctxt_sess.Session.sess_log_trans
     then
-      let slotstr = Ast.fmt_to_str Ast.fmt_ty ty in
+      let slotstr = Fmt.fmt_to_str Ast.fmt_ty ty in
       let str = step ^ " " ^ slotstr in
         begin
           annotate str;
@@ -2785,7 +2785,7 @@ let trans_visitor
           | MEM_rc_opaque -> "MEM_rc_struct"
           | MEM_interior -> "MEM_rc_struct"
       in
-      let slotstr = Ast.fmt_to_str Ast.fmt_slot slot in
+      let slotstr = Fmt.fmt_to_str Ast.fmt_slot slot in
       let str = step ^ " " ^ mctrl_str ^ " " ^ slotstr in
         begin
           annotate str;
@@ -3733,7 +3733,7 @@ let trans_visitor
     iflog (fun _ ->
              annotate (Printf.sprintf "callee_drop_slot %d = %s "
                          (int_of_node slot_id)
-                         (Ast.fmt_to_str Ast.fmt_slot_key k)));
+                         (Fmt.fmt_to_str Ast.fmt_slot_key k)));
     drop_slot_in_current_frame (cell_of_block_slot slot_id) slot None
 
 
@@ -3829,7 +3829,7 @@ let trans_visitor
                                (Printf.sprintf
                                   "post-stmt, drop_slot %d = %s "
                                   (int_of_node slot_id)
-                                  (Ast.fmt_to_str Ast.fmt_slot_key k)));
+                                  (Fmt.fmt_to_str Ast.fmt_slot_key k)));
                     drop_slot_in_current_frame
                       (cell_of_block_slot slot_id) slot None
               end
@@ -3841,7 +3841,7 @@ let trans_visitor
       iflog
         begin
           fun _ ->
-            let s = Ast.fmt_to_str Ast.fmt_stmt_body stmt in
+            let s = Fmt.fmt_to_str Ast.fmt_stmt_body stmt in
               log cx "translating stmt: %s" s;
               annotate s;
         end;
@@ -4910,7 +4910,7 @@ let fixup_assigning_visitor
     : Walk.visitor =
 
   let path_name (_:unit) : string =
-    Ast.fmt_to_str Ast.fmt_name (Walk.path_to_name path)
+    Fmt.fmt_to_str Ast.fmt_name (Walk.path_to_name path)
   in
 
   let enter_file_for id =
diff --git a/src/boot/me/typestate.ml b/src/boot/me/typestate.ml
index 4671d0f4..1824a56d 100644
--- a/src/boot/me/typestate.ml
+++ b/src/boot/me/typestate.ml
@@ -91,7 +91,7 @@ let fmt_constr_key cx ckey =
         let fmt_constr_arg carg =
           match carg with
               Constr_arg_lit lit ->
-                Ast.fmt_to_str Ast.fmt_lit lit
+                Fmt.fmt_to_str Ast.fmt_lit lit
             | Constr_arg_node (id, pth) ->
                 let rec fmt_pth pth =
                   match pth with
@@ -99,19 +99,19 @@ let fmt_constr_key cx ckey =
                         if referent_is_slot cx id
                         then
                           let key = Hashtbl.find cx.ctxt_slot_keys id in
-                            Ast.fmt_to_str Ast.fmt_slot_key key
+                            Fmt.fmt_to_str Ast.fmt_slot_key key
                         else
                           let n = Hashtbl.find cx.ctxt_all_item_names id in
-                            Ast.fmt_to_str Ast.fmt_name n
+                            Fmt.fmt_to_str Ast.fmt_name n
                     | Ast.CARG_ext (pth, nc) ->
                         let b = fmt_pth pth in
-                          b ^ (Ast.fmt_to_str Ast.fmt_name_component nc)
+                          b ^ (Fmt.fmt_to_str Ast.fmt_name_component nc)
                 in
                   fmt_pth pth
         in
         let pred_name = Hashtbl.find cx.ctxt_all_item_names cid in
           Printf.sprintf "%s(%s)"
-            (Ast.fmt_to_str Ast.fmt_name pred_name)
+            (Fmt.fmt_to_str Ast.fmt_name pred_name)
             (String.concat ", "
                (List.map
                   fmt_constr_arg
@@ -120,7 +120,7 @@ let fmt_constr_key cx ckey =
     | Constr_init n when Hashtbl.mem cx.ctxt_slot_keys n ->
         Printf.sprintf "<init #%d = %s>"
           (int_of_node n)
-          (Ast.fmt_to_str Ast.fmt_slot_key (Hashtbl.find cx.ctxt_slot_keys n))
+          (Fmt.fmt_to_str Ast.fmt_slot_key (Hashtbl.find cx.ctxt_slot_keys n))
     | Constr_init n ->
         Printf.sprintf "<init #%d>" (int_of_node n)
 ;;
@@ -820,7 +820,7 @@ let run_dataflow cx graph : unit =
               iflog cx (fun _ -> log cx "stmt %d: '%s'" (int_of_node node)
                        (match htab_search cx.ctxt_all_stmts node with
                             None -> "??"
-                          | Some stmt -> Ast.fmt_to_str Ast.fmt_stmt stmt));
+                          | Some stmt -> Fmt.fmt_to_str Ast.fmt_stmt stmt));
               iflog cx (fun _ -> log cx "stmt %d:" (int_of_node node));
               iflog cx (fun _ -> log cx
                           "    prestate %s" (fmt_constr_bitv prestate));
@@ -875,7 +875,7 @@ let typestate_verify_visitor
                  "Unsatisfied precondition constraint %s at stmt %d: %s"
                  constr_str
                  (int_of_node s.id)
-                 (Ast.fmt_to_str Ast.fmt_stmt
+                 (Fmt.fmt_to_str Ast.fmt_stmt
                     (Hashtbl.find cx.ctxt_all_stmts s.id)))
         (Bits.to_list precond);
       inner.Walk.visit_stmt_pre s
diff --git a/src/boot/me/walk.ml b/src/boot/me/walk.ml
index a8d74cad..30b30e32 100644
--- a/src/boot/me/walk.ml
+++ b/src/boot/me/walk.ml
@@ -145,7 +145,7 @@ let mod_item_logging_visitor
     (path:Ast.name_component Stack.t)
     (inner:visitor)
     : visitor =
-  let path_name _ = Ast.fmt_to_str Ast.fmt_name (path_to_name path) in
+  let path_name _ = Fmt.fmt_to_str Ast.fmt_name (path_to_name path) in
   let visit_mod_item_pre name params item =
     logfn (Printf.sprintf "entering %s" (path_name()));
     inner.visit_mod_item_pre name params item;