src/boot/me/loop.ml

   1 (*
   2  * Computes iterator-loop nesting depths and max depth of each function.
   3  *)
   4
   5 open Semant;;
   6 open Common;;
   7
   8 let log cx = Session.log "loop"
   9   cx.ctxt_sess.Session.sess_log_loop
  10   cx.ctxt_sess.Session.sess_log_out
  11 ;;
  12
  13 type fn_ctxt = { current_depth: int;  }
  14 ;;
  15
  16 let incr_depth (fcx:fn_ctxt) =
  17     { current_depth = fcx.current_depth + 1; }
  18 ;;
  19
  20 let decr_depth (fcx:fn_ctxt) =
  21   { current_depth = fcx.current_depth - 1; }
  22 ;;
  23
  24 let top_fcx = { current_depth = 0; }
  25 ;;
  26
  27 let loop_depth_visitor
  28     (cx:ctxt)
  29     (inner:Walk.visitor)
  30     : Walk.visitor =
  31
  32   let (fcxs : fn_ctxt Stack.t) = Stack.create () in
  33
  34   let push_loop () =
  35     let fcx = Stack.pop fcxs in
  36       Stack.push (incr_depth fcx) fcxs
  37   in
  38
  39   let pop_loop () =
  40     let fcx = Stack.pop fcxs in
  41       Stack.push (decr_depth fcx) fcxs
  42   in
  43
  44   let visit_mod_item_pre
  45       (ident:Ast.ident)
  46       (ty_params:(Ast.ty_param identified) array)
  47       (item:Ast.mod_item)
  48       : unit =
  49     Stack.push top_fcx fcxs;
  50     inner.Walk.visit_mod_item_pre ident ty_params item
  51   in
  52
  53   let visit_mod_item_post
  54       (ident:Ast.ident)
  55       (ty_params:(Ast.ty_param identified) array)
  56       (item:Ast.mod_item)
  57       : unit =
  58     inner.Walk.visit_mod_item_post ident ty_params item;
  59     ignore (Stack.pop fcxs);
  60   in
  61
  62   let visit_obj_fn_pre
  63       (obj:Ast.obj identified)
  64       (ident:Ast.ident)
  65       (fn:Ast.fn identified)
  66       : unit =
  67     Stack.push top_fcx fcxs;
  68     inner.Walk.visit_obj_fn_pre obj ident fn
  69   in
  70
  71   let visit_obj_fn_post
  72       (obj:Ast.obj identified)
  73       (ident:Ast.ident)
  74       (fn:Ast.fn identified)
  75       : unit =
  76     inner.Walk.visit_obj_fn_pre obj ident fn;
  77     ignore (Stack.pop fcxs)
  78   in
  79
  80   let visit_obj_drop_pre
  81       (obj:Ast.obj identified)
  82       (b:Ast.block)
  83       : unit =
  84     Stack.push top_fcx fcxs;
  85     inner.Walk.visit_obj_drop_pre obj b
  86   in
  87
  88   let visit_obj_drop_post
  89       (obj:Ast.obj identified)
  90       (b:Ast.block)
  91       : unit =
  92     inner.Walk.visit_obj_drop_post obj b;
  93     ignore (Stack.pop fcxs)
  94   in
  95
  96   let visit_slot_identified_pre sloti =
  97     let fcx = Stack.top fcxs in
  98       htab_put cx.ctxt_slot_loop_depths sloti.id fcx.current_depth;
  99       inner.Walk.visit_slot_identified_pre sloti
 100   in
 101
 102   let visit_stmt_pre s =
 103     let fcx = Stack.top fcxs in
 104       htab_put cx.ctxt_stmt_loop_depths s.id fcx.current_depth;
 105       begin
 106         match s.node with
 107           | Ast.STMT_for_each fe ->
 108               htab_put cx.ctxt_block_is_loop_body fe.Ast.for_each_body.id ();
 109           | _ -> ()
 110     end;
 111     inner.Walk.visit_stmt_pre s
 112   in
 113
 114   let visit_block_pre b =
 115     if Hashtbl.mem cx.ctxt_block_is_loop_body b.id
 116     then push_loop ();
 117     inner.Walk.visit_block_pre b
 118   in
 119
 120   let visit_block_post b =
 121     inner.Walk.visit_block_post b;
 122     if Hashtbl.mem cx.ctxt_block_is_loop_body b.id
 123     then pop_loop ()
 124   in
 125
 126     { inner with
 127         Walk.visit_mod_item_pre = visit_mod_item_pre;
 128         Walk.visit_mod_item_post = visit_mod_item_post;
 129         Walk.visit_obj_fn_pre = visit_obj_fn_pre;
 130         Walk.visit_obj_fn_post = visit_obj_fn_post;
 131         Walk.visit_obj_drop_pre = visit_obj_drop_pre;
 132         Walk.visit_obj_drop_post = visit_obj_drop_post;
 133         Walk.visit_slot_identified_pre = visit_slot_identified_pre;
 134         Walk.visit_stmt_pre = visit_stmt_pre;
 135         Walk.visit_block_pre = visit_block_pre;
 136         Walk.visit_block_post = visit_block_post }
 137 ;;
 138
 139 let process_crate
 140     (cx:ctxt)
 141     (crate:Ast.crate)
 142     : unit =
 143   let path = Stack.create () in
 144   let passes =
 145     [|
 146       (loop_depth_visitor cx
 147          Walk.empty_visitor)
 148     |]
 149   in
 150
 151     run_passes cx "loop" path passes (log cx "%s") crate;
 152     ()
 153 ;;
 154
 155
 156 (*
 157  * Local Variables:
 158  * fill-column: 78;
 159  * indent-tabs-mode: nil
 160  * buffer-file-coding-system: utf-8-unix
 161  * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
 162  * End:
 163  *)