5.44. Optimisation stuff

Name binding pass 2.
Start ocaml section to src/flx_call.mli[1 /1 ]
     1: # 6 "./lpsrc/flx_call.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: 
     7: type usage_table_t =  (bid_t, (bid_t * range_srcref) list) Hashtbl.t
     8: type usage_t =  usage_table_t * usage_table_t
     9: 
    10: val call_data:
    11:   sym_state_t -> fully_bound_symbol_table_t -> usage_t
    12: 
    13: val print_call_report:
    14:   sym_state_t -> fully_bound_symbol_table_t -> out_channel -> unit
    15: 
    16: val is_recursive_call: usage_table_t -> bid_t -> bid_t -> bool
    17: val is_recursive: usage_table_t -> bid_t -> bool
    18: 
    19: val cal_exe_usage:
    20:   sym_state_t -> usage_table_t -> int -> bexe_t -> unit
    21: 
    22: val cal_param_usage:
    23:   sym_state_t ->
    24:   usage_table_t ->
    25:   range_srcref ->
    26:   int ->
    27:   bparameter_t ->
    28:   unit
    29: 
    30: val use_closure:
    31:   usage_table_t -> int -> IntSet.t
    32: 
    33: val child_use_closure:
    34:   IntSet.t -> usage_table_t -> int -> IntSet.t
    35: 
    36: val expr_uses:
    37:  sym_state_t ->
    38:  IntSet.t ->
    39:  usage_table_t ->
    40:  IntSet.t ->
    41:  tbexpr_t ->
    42:  IntSet.t
    43: 
End ocaml section to src/flx_call.mli[1]
Start ocaml section to src/flx_call.ml[1 /1 ]
     1: # 50 "./lpsrc/flx_call.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_srcref
     5: open Flx_mtypes1
     6: open List
     7: open Flx_exceptions
     8: open Flx_maps
     9: open Flx_util
    10: open Flx_print
    11: open Flx_mtypes2
    12: 
    13: type usage_table_t =  (bid_t, (bid_t * range_srcref) list) Hashtbl.t
    14: type usage_t =  usage_table_t * usage_table_t
    15: 
    16: let add (h:usage_table_t) k j sr =
    17:   (*
    18:   print_endline ("Adding use of " ^ si j ^ " in " ^ si k);
    19:   *)
    20:   Hashtbl.replace h k
    21:   (
    22:     (j,sr)
    23:     ::
    24:     (
    25:       try Hashtbl.find h k
    26:       with Not_found -> []
    27:     )
    28:   )
    29: 
    30: let rec process_expr h k sr ((e,t) as be) =
    31:   let ue e = process_expr h k sr e in
    32:   let ui i = add h k i sr in
    33:   (* Use the flx_maps iterator now! *)
    34:   iter_tbexpr ui ignore ignore be
    35: 
    36: and cal_exe_usage syms h k exe =
    37:   (*
    38:   print_endline ("Checking uses in " ^ si k ^ ", exe: " ^ string_of_bexe syms.dfns 2 exe);
    39:   *)
    40:   let sr = src_of_bexe exe in
    41:   let ue e = process_expr h k sr e in
    42:   let ui i = add h k i sr in
    43:   (* USE A MAP *)
    44:   iter_bexe ui ue ignore ignore ignore exe
    45: 
    46: let uses_production h k sr p =
    47:   let uses_symbol (_,nt) = match nt with
    48:   | `Nonterm jj -> iter (fun i -> add h k i sr) jj
    49:   | `Term _ -> () (* HACK! This is a union constructor name  we need to 'use' the union type!! *)
    50:   in
    51:   iter uses_symbol p
    52: 
    53: let cal_param_usage syms uses sr parent (_,(child,_)) =
    54:   add uses parent child sr
    55: 
    56: let call_data syms (bbdfns:fully_bound_symbol_table_t):usage_t =
    57:   let uses = Hashtbl.create 97 in
    58:   let usedby = Hashtbl.create 97 in
    59:   let usage = uses,usedby in
    60:   Hashtbl.iter
    61:   (fun k (_,_,sr,entry) -> match entry with
    62:   | `BBDCL_procedure (_,_,(ps,_),exes)
    63:   | `BBDCL_function (_,_,(ps,_),_,exes) ->
    64:     iter (cal_param_usage syms uses sr k) ps;
    65:     iter (cal_exe_usage syms uses k) exes
    66: 
    67:   | `BBDCL_glr (_,_,_,(p,exes)) ->
    68:     iter (cal_exe_usage syms uses k) exes;
    69:     uses_production uses k sr p
    70: 
    71:   | `BBDCL_regmatch (_,_,(ps,_),_,(_,_,h,_))
    72:   | `BBDCL_reglex (_,_,(ps,_),_,_,(_,_,h,_)) ->
    73:     iter (cal_param_usage syms uses sr k) ps;
    74:     Hashtbl.iter (fun _ e -> process_expr uses k sr e) h
    75: 
    76:   | _ -> ()
    77:   )
    78:   bbdfns
    79:   ;
    80:   (* invert uses table to get usedby table *)
    81:   Hashtbl.iter
    82:   (fun k ls ->
    83:     iter
    84:     (fun (i,sr) -> add usedby i k sr)
    85:     ls
    86:   )
    87:   uses
    88:   ;
    89:   usage
    90: 
    91: (* closure of i, excluding i unless it is recursive! *)
    92: let cls h i =
    93:   let c = ref IntSet.empty in
    94:   let rec add j =
    95:     if not (IntSet.mem j !c) then
    96:     begin
    97:       c := IntSet.add j !c;
    98:       let x = try Hashtbl.find h j with Not_found -> [] in
    99:       iter (fun (j,_) -> add j) x
   100:     end
   101:   in
   102:     let x = try Hashtbl.find h i with Not_found -> [] in
   103:     iter (fun (j,_) -> add j) x
   104:     ;
   105:     !c
   106: 
   107: let is_recursive_call h caller callee = IntSet.mem caller (cls h callee)
   108: let is_recursive h i = is_recursive_call h i i
   109: 
   110: let use_closure h i = cls h i
   111: 
   112: (* this calculates the use closure of i, eliminating recursive
   113:   calls to the base function by restricting references
   114:   to some set k. Note this means the usage of k is also
   115:   not included.
   116: 
   117:   If k is set to the children of some function f,
   118:   then this routine will not report usage of any
   119:   variables in f via calls to f, only direct
   120:   uses in some child which is called; in particular
   121:   calls to outside the child tree of f are not tracked
   122:   since they can't call any children of f,
   123:   so they can only use them via a call to f.
   124:   This would spawn a new stack frame, and so
   125:   refer to different copies of variables.
   126: 
   127:   This routine is used to find which variables
   128:   in f an expression in f can use via a call to a child.
   129: 
   130:   OUCH OUCH OUCH. I THINK THIS IDEA MUST BE BUGGED!
   131: 
   132:   Here's the problem. Given
   133: 
   134:   fun A(){
   135:     fun B { fun C() {} return C; }
   136:     fun D(f) { f 1; }
   137:     D (B());
   138:   }
   139: 
   140:   function B is returning a closure of C,
   141:   which is being passed into D and called.
   142:   Note D cannot see the function C.
   143: 
   144:   The inliner should handle this correctly:
   145:   B is inlined to return a *clone* C' of C which
   146:   is nested in A, then D is inlined, resulting
   147:   in the call C' 1 (which can now be inlined too).
   148: 
   149:   The problem is that the assumption "calls outside
   150:   the child tree of f are not tracked since they can't
   151:   call any children of f" is wrong. A call outside
   152:   the tree can still execute something inside
   153:   the tree via a closure .. however how does the
   154:   closure get out .. it has to be 'made' by someon
   155:   who can see it ..
   156: 
   157: *)
   158: 
   159: let child_use_closure k h i =
   160:   let c = ref IntSet.empty in
   161:   let rec add j =
   162:     if not (IntSet.mem j !c) && IntSet.mem j k then
   163:     begin
   164:       c := IntSet.add j !c;
   165:       let x = try Hashtbl.find h j with Not_found -> [] in
   166:       iter (fun (j,_) -> add j) x
   167:     end
   168:   in
   169:     let x = try Hashtbl.find h i with Not_found -> [] in
   170:     iter (fun (j,_) ->  add j) x
   171:     ;
   172:     !c
   173: 
   174: 
   175: let call_report syms bbdfns (uses,usedby) f k =
   176:   let si = string_of_int in
   177:   let catmap = Flx_util.catmap in
   178:   let w s = output_string f s in
   179:   let isr = is_recursive uses k in
   180:   let id,_,sr,entry = Hashtbl.find bbdfns k in
   181:   w (si k ^ ": ");
   182:   w (if isr then "recursive " else "");
   183:   w
   184:     begin match entry with
   185:     | `BBDCL_function _ -> "fun "
   186:     | `BBDCL_procedure _ -> "proc "
   187:     | `BBDCL_var _ -> "var "
   188:     | `BBDCL_val _ -> "val "
   189:     | _ -> assert false
   190:     end
   191:   ;
   192:   w (id ^ " uses: ");
   193:   let u = try Hashtbl.find uses k with Not_found -> [] in
   194:   let x = ref [] in
   195:   iter
   196:   (fun (i,_) ->
   197:     if not (mem i !x) then
   198:     try match Hashtbl.find bbdfns i with
   199:       | _,_,_,`BBDCL_procedure _
   200:       | _,_,_,`BBDCL_function _
   201:       | _,_,_,`BBDCL_var _
   202:       | _,_,_,`BBDCL_val _ -> x := i::!x
   203:       | _ -> ()
   204:     with Not_found -> ()
   205:   )
   206:   u;
   207:   let u = sort compare !x in
   208:   w (catmap "," si u);
   209:   w "; usedby: ";
   210:   let u = try Hashtbl.find usedby k with Not_found -> [] in
   211:   let x = ref [] in
   212:   iter (fun (i,_) -> if not (mem i !x) then x := i::!x) u;
   213:   let u = sort compare !x in
   214:   w (catmap "," si u);
   215:   w "\n"
   216: 
   217: let print_call_report' syms bbdfns usage f =
   218:   let x = ref [] in
   219:   Hashtbl.iter
   220:   (fun k (id,_,sr,entry) ->
   221:     match entry with
   222:     | `BBDCL_procedure _
   223:     | `BBDCL_function _
   224:     | `BBDCL_var _
   225:     | `BBDCL_val _
   226:       -> x := k :: !x
   227:     | _ -> ()
   228:   )
   229:   bbdfns
   230:   ;
   231:   iter
   232:     (call_report syms bbdfns usage f)
   233:     (sort compare (!x))
   234: 
   235: let print_call_report syms bbdfns f =
   236:   let usage = call_data syms bbdfns in
   237:   print_call_report' syms bbdfns usage f
   238: 
   239: let expr_uses syms descend usage restrict e =
   240:   let u = ref IntSet.empty in
   241:   let add u i = u := IntSet.add i !u in
   242:   iter_tbexpr (add u) ignore ignore e;
   243: 
   244: 
   245:   (*
   246:   print_string ("Direct usage of expr " ^ sbe syms.dfns e ^ ": ");
   247:   IntSet.iter (fun i -> print_string (si i^" ")) !u;
   248:   print_endline "";
   249: 
   250: 
   251:   print_string ("Restrict =  ");
   252:   IntSet.iter (fun i -> print_string (si i^" ")) restrict;
   253:   print_endline "";
   254:   *)
   255: 
   256:   let u = IntSet.fold
   257:     (fun i cls -> IntSet.union cls (
   258:      let cl = child_use_closure descend usage i in
   259:      (*
   260:      print_string ("Closure of " ^ si i ^ " is: ");
   261:      IntSet.iter (fun i -> print_string (si i ^ " ")) cl;
   262:      print_endline "";
   263:      *)
   264:      cl
   265:     ))
   266:     !u
   267:     !u
   268:   in let u = IntSet.inter restrict u in
   269:   (*
   270:   print_string ("Restricted usage of expr " ^ sbe syms.dfns e ^ ": ");
   271:   IntSet.iter (fun i -> print_string (si i^" ")) u;
   272:   print_endline "";
   273:   *)
   274:   u
   275: 
   276: 
End ocaml section to src/flx_call.ml[1]