Populate tree.

1 files changed, 163 insertions, 0 deletions

diff --git a/src/boot/me/loop.ml b/src/boot/me/loop.ml
new file mode 100644
index 00000000..c23c4afd
--- /dev/null
+++ b/src/boot/me/loop.ml
@@ -0,0 +1,163 @@
+(*
+ * Computes iterator-loop nesting depths and max depth of each function.
+ *)
+
+open Semant;;
+open Common;;
+
+let log cx = Session.log "loop"
+  cx.ctxt_sess.Session.sess_log_loop
+  cx.ctxt_sess.Session.sess_log_out
+;;
+
+type fn_ctxt = { current_depth: int;  }
+;;
+
+let incr_depth (fcx:fn_ctxt) =
+    { current_depth = fcx.current_depth + 1; }
+;;
+
+let decr_depth (fcx:fn_ctxt) =
+  { current_depth = fcx.current_depth - 1; }
+;;
+
+let top_fcx = { current_depth = 0; }
+;;
+
+let loop_depth_visitor
+    (cx:ctxt)
+    (inner:Walk.visitor)
+    : Walk.visitor =
+
+  let (fcxs : fn_ctxt Stack.t) = Stack.create () in
+
+  let push_loop () =
+    let fcx = Stack.pop fcxs in
+      Stack.push (incr_depth fcx) fcxs
+  in
+
+  let pop_loop () =
+    let fcx = Stack.pop fcxs in
+      Stack.push (decr_depth fcx) fcxs
+  in
+
+  let visit_mod_item_pre
+      (ident:Ast.ident)
+      (ty_params:(Ast.ty_param identified) array)
+      (item:Ast.mod_item)
+      : unit =
+    Stack.push top_fcx fcxs;
+    inner.Walk.visit_mod_item_pre ident ty_params item
+  in
+
+  let visit_mod_item_post
+      (ident:Ast.ident)
+      (ty_params:(Ast.ty_param identified) array)
+      (item:Ast.mod_item)
+      : unit =
+    inner.Walk.visit_mod_item_post ident ty_params item;
+    ignore (Stack.pop fcxs);
+  in
+
+  let visit_obj_fn_pre
+      (obj:Ast.obj identified)
+      (ident:Ast.ident)
+      (fn:Ast.fn identified)
+      : unit =
+    Stack.push top_fcx fcxs;
+    inner.Walk.visit_obj_fn_pre obj ident fn
+  in
+
+  let visit_obj_fn_post
+      (obj:Ast.obj identified)
+      (ident:Ast.ident)
+      (fn:Ast.fn identified)
+      : unit =
+    inner.Walk.visit_obj_fn_pre obj ident fn;
+    ignore (Stack.pop fcxs)
+  in
+
+  let visit_obj_drop_pre
+      (obj:Ast.obj identified)
+      (b:Ast.block)
+      : unit =
+    Stack.push top_fcx fcxs;
+    inner.Walk.visit_obj_drop_pre obj b
+  in
+
+  let visit_obj_drop_post
+      (obj:Ast.obj identified)
+      (b:Ast.block)
+      : unit =
+    inner.Walk.visit_obj_drop_post obj b;
+    ignore (Stack.pop fcxs)
+  in
+
+  let visit_slot_identified_pre sloti =
+    let fcx = Stack.top fcxs in
+      htab_put cx.ctxt_slot_loop_depths sloti.id fcx.current_depth;
+      inner.Walk.visit_slot_identified_pre sloti
+  in
+
+  let visit_stmt_pre s =
+    let fcx = Stack.top fcxs in
+      htab_put cx.ctxt_stmt_loop_depths s.id fcx.current_depth;
+      begin
+        match s.node with
+          | Ast.STMT_for_each fe ->
+              htab_put cx.ctxt_block_is_loop_body fe.Ast.for_each_body.id ();
+          | _ -> ()
+    end;
+    inner.Walk.visit_stmt_pre s
+  in
+
+  let visit_block_pre b =
+    if Hashtbl.mem cx.ctxt_block_is_loop_body b.id
+    then push_loop ();
+    inner.Walk.visit_block_pre b
+  in
+
+  let visit_block_post b =
+    inner.Walk.visit_block_post b;
+    if Hashtbl.mem cx.ctxt_block_is_loop_body b.id
+    then pop_loop ()
+  in
+
+    { inner with
+        Walk.visit_mod_item_pre = visit_mod_item_pre;
+        Walk.visit_mod_item_post = visit_mod_item_post;
+        Walk.visit_obj_fn_pre = visit_obj_fn_pre;
+        Walk.visit_obj_fn_post = visit_obj_fn_post;
+        Walk.visit_obj_drop_pre = visit_obj_drop_pre;
+        Walk.visit_obj_drop_post = visit_obj_drop_post;
+        Walk.visit_slot_identified_pre = visit_slot_identified_pre;
+        Walk.visit_stmt_pre = visit_stmt_pre;
+        Walk.visit_block_pre = visit_block_pre;
+        Walk.visit_block_post = visit_block_post }
+;;
+
+let process_crate
+    (cx:ctxt)
+    (crate:Ast.crate)
+    : unit =
+  let path = Stack.create () in
+  let passes =
+    [|
+      (loop_depth_visitor cx
+         Walk.empty_visitor)
+    |]
+  in
+
+    run_passes cx "loop" path passes (log cx "%s") crate;
+    ()
+;;
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)