5.47. 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_expr_usage:
    23:   sym_state_t -> usage_table_t -> int -> range_srcref -> tbexpr_t -> unit
    24: 
    25: val cal_param_usage:
    26:   sym_state_t ->
    27:   usage_table_t ->
    28:   range_srcref ->
    29:   int ->
    30:   bparameter_t ->
    31:   unit
    32: 
    33: val use_closure:
    34:   usage_table_t -> int -> IntSet.t
    35: 
    36: val child_use_closure:
    37:   IntSet.t -> usage_table_t -> int -> IntSet.t
    38: 
    39: val expr_uses:
    40:  sym_state_t ->
    41:  IntSet.t ->
    42:  usage_table_t ->
    43:  IntSet.t ->
    44:  tbexpr_t ->
    45:  IntSet.t
    46: 
End ocaml section to src/flx_call.mli[1]
Start ocaml section to src/flx_call.ml[1 /1 ]
     1: # 53 "./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: 
    14: (* NOTE: THIS CODE LARGELY DUPLICATES CODE IN flx_use.ml *)
    15: 
    16: type usage_table_t =  (bid_t, (bid_t * range_srcref) list) Hashtbl.t
    17: type usage_t =  usage_table_t * usage_table_t
    18: 
    19: let add (h:usage_table_t) k j sr =
    20:   (*
    21:   print_endline ("Adding use of " ^ si j ^ " in " ^ si k);
    22:   *)
    23:   Hashtbl.replace h k
    24:   (
    25:     (j,sr)
    26:     ::
    27:     (
    28:       try Hashtbl.find h k
    29:       with Not_found -> []
    30:     )
    31:   )
    32: 
    33: let rec uses_type h k sr t =
    34:   let ut t = uses_type h k sr t in
    35:   match t with
    36:   | `BTYP_inst (i,ts)
    37:     ->
    38:       add h k i sr;
    39:       iter ut ts
    40: 
    41:   | _ -> iter_btype ut t
    42: 
    43: 
    44: 
    45: let faulty_req syms i =
    46:   match Hashtbl.find syms.dfns i with {id=id; sr=sr } ->
    47:   clierr sr (id ^ " is used but has unsatisfied requirement")
    48: 
    49: 
    50: let rec process_expr h k sr e =
    51:   let ue e = process_expr h k sr e in
    52:   let ui i = add h k i sr in
    53:   let ut t = uses_type h k sr t in
    54:   iter_tbexpr ui ignore ut e
    55: 
    56: and cal_exe_usage syms h k exe =
    57:   (*
    58:   print_endline ("Checking uses in " ^ si k ^ ", exe: " ^ string_of_bexe syms.dfns 2 exe);
    59:   *)
    60:   let sr = src_of_bexe exe in
    61:   let ue e = process_expr h k sr e in
    62:   let ui i = add h k i sr in
    63:   let ut t = uses_type h k sr t in
    64:   iter_bexe ui ue ut ignore ignore exe
    65: 
    66: let cal_expr_usage syms h k sr e =
    67:   process_expr h k sr e
    68: 
    69: let uses_production h k sr p =
    70:   let uses_symbol (_,nt) = match nt with
    71:   | `Nonterm jj -> iter (fun i -> add h k i sr) jj
    72:   | `Term _ -> () (* HACK! This is a union constructor name  we need to 'use' the union type!! *)
    73:   in
    74:   iter uses_symbol p
    75: 
    76: let cal_param_usage syms uses sr parent {pindex=child;ptyp=t} =
    77:   uses_type uses parent sr t;
    78:   add uses parent child sr
    79: 
    80: let call_data syms (bbdfns:fully_bound_symbol_table_t):usage_t =
    81:   let uses = Hashtbl.create 97 in
    82:   let usedby = Hashtbl.create 97 in
    83:   let usage = uses,usedby in
    84:   let cal_req_usage sr parent reqs =
    85:     let ur (j,ts) =
    86:       if j = 0 then faulty_req syms parent
    87:       else add uses parent j sr
    88:     in
    89:     iter ur reqs
    90:   in
    91:   Hashtbl.iter
    92:   (fun k (_,_,sr,entry) ->
    93:   let ut t = uses_type uses k sr t in
    94: 
    95:   match entry with
    96:   | `BBDCL_typeclass _ -> ()
    97: 
    98:   | `BBDCL_procedure (_,_,(ps,_),exes)
    99:   | `BBDCL_function (_,_,(ps,_),_,exes) ->
   100:     iter (cal_param_usage syms uses sr k) ps;
   101:     iter (cal_exe_usage syms uses k) exes
   102: 
   103:   | `BBDCL_glr (_,_,_,(p,exes)) ->
   104:     iter (cal_exe_usage syms uses k) exes;
   105:     uses_production uses k sr p
   106: 
   107:   | `BBDCL_regmatch (_,_,(ps,_),_,(_,_,h,_))
   108:   | `BBDCL_reglex (_,_,(ps,_),_,_,(_,_,h,_)) ->
   109:     iter (cal_param_usage syms uses sr k) ps;
   110:     Hashtbl.iter (fun _ e -> process_expr uses k sr e) h
   111: 
   112:   | `BBDCL_newtype (_,t) -> ut t
   113:   | `BBDCL_abs (_,_,_,reqs) -> cal_req_usage sr k reqs
   114:   | `BBDCL_const (_,t,_,reqs) -> cal_req_usage sr k reqs
   115:   | `BBDCL_proc (_,_,ps,_, reqs)  -> cal_req_usage sr k reqs; iter ut ps
   116:   | `BBDCL_fun (_,_,ps,ret,_, reqs,_)  -> cal_req_usage sr k reqs; iter ut ps; ut ret
   117:   | `BBDCL_insert (_,_,_,reqs)  -> cal_req_usage sr k reqs
   118:   | `BBDCL_instance (_,_,cons,i,ts) ->
   119:     (* we dont add the type constraint, since it
   120:     is only used for instance selection
   121:     *)
   122:     add uses k i sr; iter ut ts
   123: 
   124:   | `BBDCL_nonconst_ctor (_,_,unt,_,ct, evs, etraint) ->
   125:     ut unt; ut ct
   126: 
   127:   | `BBDCL_union _  -> ()
   128: 
   129:   | `BBDCL_struct (_,ps)
   130:   | `BBDCL_cstruct (_,ps)  ->
   131:     iter ut (map snd ps)
   132: 
   133:   | `BBDCL_class _ -> ()
   134:   | `BBDCL_cclass _ -> ()
   135:   | `BBDCL_val (_,t)
   136:   | `BBDCL_var (_,t)
   137:   | `BBDCL_tmp (_,t) -> ut t
   138:   | `BBDCL_ref (_,t) -> ut (`BTYP_pointer t)
   139:   | `BBDCL_callback (_,_,ps_cf, ps_c, _, ret, reqs,_) ->
   140:     iter ut ps_cf;
   141:     iter ut ps_c;
   142:     ut ret; cal_req_usage sr k reqs
   143: 
   144:   )
   145:   bbdfns
   146:   ;
   147:   (* invert uses table to get usedby table *)
   148:   Hashtbl.iter
   149:   (fun k ls ->
   150:     iter
   151:     (fun (i,sr) -> add usedby i k sr)
   152:     ls
   153:   )
   154:   uses
   155:   ;
   156:   usage
   157: 
   158: (* closure of i, excluding i unless it is recursive! *)
   159: let cls h i =
   160:   let c = ref IntSet.empty in
   161:   let rec add j =
   162:     if not (IntSet.mem j !c) 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: let is_recursive_call h caller callee = IntSet.mem caller (cls h callee)
   175: let is_recursive h i = is_recursive_call h i i
   176: 
   177: let use_closure h i = cls h i
   178: 
   179: (* this calculates the use closure of i, eliminating recursive
   180:   calls to the base function by restricting references
   181:   to some set k. Note this means the usage of k is also
   182:   not included.
   183: 
   184:   If k is set to the children of some function f,
   185:   then this routine will not report usage of any
   186:   variables in f via calls to f, only direct
   187:   uses in some child which is called; in particular
   188:   calls to outside the child tree of f are not tracked
   189:   since they can't call any children of f,
   190:   so they can only use them via a call to f.
   191:   This would spawn a new stack frame, and so
   192:   refer to different copies of variables.
   193: 
   194:   This routine is used to find which variables
   195:   in f an expression in f can use via a call to a child.
   196: 
   197:   OUCH OUCH OUCH. I THINK THIS IDEA MUST BE BUGGED!
   198: 
   199:   Here's the problem. Given
   200: 
   201:   fun A(){
   202:     fun B { fun C() {} return C; }
   203:     fun D(f) { f 1; }
   204:     D (B());
   205:   }
   206: 
   207:   function B is returning a closure of C,
   208:   which is being passed into D and called.
   209:   Note D cannot see the function C.
   210: 
   211:   The inliner should handle this correctly:
   212:   B is inlined to return a *clone* C' of C which
   213:   is nested in A, then D is inlined, resulting
   214:   in the call C' 1 (which can now be inlined too).
   215: 
   216:   The problem is that the assumption "calls outside
   217:   the child tree of f are not tracked since they can't
   218:   call any children of f" is wrong. A call outside
   219:   the tree can still execute something inside
   220:   the tree via a closure .. however how does the
   221:   closure get out .. it has to be 'made' by someon
   222:   who can see it ..
   223: 
   224: *)
   225: 
   226: let child_use_closure k h i =
   227:   let c = ref IntSet.empty in
   228:   let rec add j =
   229:     if not (IntSet.mem j !c) && IntSet.mem j k then
   230:     begin
   231:       c := IntSet.add j !c;
   232:       let x = try Hashtbl.find h j with Not_found -> [] in
   233:       iter (fun (j,_) -> add j) x
   234:     end
   235:   in
   236:     let x = try Hashtbl.find h i with Not_found -> [] in
   237:     iter (fun (j,_) ->  add j) x
   238:     ;
   239:     !c
   240: 
   241: 
   242: let call_report syms bbdfns (uses,usedby) f k =
   243:   let si = string_of_int in
   244:   let catmap = Flx_util.catmap in
   245:   let w s = output_string f s in
   246:   let isr = is_recursive uses k in
   247:   let id,_,sr,entry = Hashtbl.find bbdfns k in
   248:   w (si k ^ ": ");
   249:   w (if isr then "recursive " else "");
   250:   w
   251:     begin match entry with
   252:     | `BBDCL_function _ -> "fun "
   253:     | `BBDCL_procedure _ -> "proc "
   254:     | `BBDCL_var _ -> "var "
   255:     | `BBDCL_val _ -> "val "
   256:     | _ -> assert false
   257:     end
   258:   ;
   259:   w (id ^ " uses: ");
   260:   let u = try Hashtbl.find uses k with Not_found -> [] in
   261:   let x = ref [] in
   262:   iter
   263:   (fun (i,_) ->
   264:     if not (mem i !x) then
   265:     try match Hashtbl.find bbdfns i with
   266:       | _,_,_,`BBDCL_procedure _
   267:       | _,_,_,`BBDCL_function _
   268:       | _,_,_,`BBDCL_var _
   269:       | _,_,_,`BBDCL_val _ -> x := i::!x
   270:       | _ -> ()
   271:     with Not_found -> ()
   272:   )
   273:   u;
   274:   let u = sort compare !x in
   275:   w (catmap "," si u);
   276:   w "; usedby: ";
   277:   let u = try Hashtbl.find usedby k with Not_found -> [] in
   278:   let x = ref [] in
   279:   iter (fun (i,_) -> if not (mem i !x) then x := i::!x) u;
   280:   let u = sort compare !x in
   281:   w (catmap "," si u);
   282:   w "\n"
   283: 
   284: let print_call_report' syms bbdfns usage f =
   285:   let x = ref [] in
   286:   Hashtbl.iter
   287:   (fun k (id,_,sr,entry) ->
   288:     match entry with
   289:     | `BBDCL_procedure _
   290:     | `BBDCL_function _
   291:     | `BBDCL_var _
   292:     | `BBDCL_val _
   293:       -> x := k :: !x
   294:     | _ -> ()
   295:   )
   296:   bbdfns
   297:   ;
   298:   iter
   299:     (call_report syms bbdfns usage f)
   300:     (sort compare (!x))
   301: 
   302: let print_call_report syms bbdfns f =
   303:   let usage = call_data syms bbdfns in
   304:   print_call_report' syms bbdfns usage f
   305: 
   306: let expr_uses syms descend usage restrict e =
   307:   let u = ref IntSet.empty in
   308:   let add u i = u := IntSet.add i !u in
   309:   iter_tbexpr (add u) ignore ignore e;
   310: 
   311: 
   312:   (*
   313:   print_string ("Direct usage of expr " ^ sbe syms.dfns e ^ ": ");
   314:   IntSet.iter (fun i -> print_string (si i^" ")) !u;
   315:   print_endline "";
   316: 
   317: 
   318:   print_string ("Restrict =  ");
   319:   IntSet.iter (fun i -> print_string (si i^" ")) restrict;
   320:   print_endline "";
   321:   *)
   322: 
   323:   let u = IntSet.fold
   324:     (fun i cls -> IntSet.union cls (
   325:      let cl = child_use_closure descend usage i in
   326:      (*
   327:      print_string ("Closure of " ^ si i ^ " is: ");
   328:      IntSet.iter (fun i -> print_string (si i ^ " ")) cl;
   329:      print_endline "";
   330:      *)
   331:      cl
   332:     ))
   333:     !u
   334:     !u
   335:   in let u = IntSet.inter restrict u in
   336:   (*
   337:   print_string ("Restricted usage of expr " ^ sbe syms.dfns e ^ ": ");
   338:   IntSet.iter (fun i -> print_string (si i^" ")) u;
   339:   print_endline "";
   340:   *)
   341:   u
   342: 
   343: 
End ocaml section to src/flx_call.ml[1]