5.52. Fold vars

Start ocaml section to src/flx_foldvars.mli[1 /1 ]
     1: # 4 "./lpsrc/flx_foldvars.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: open Flx_call
     7: open Flx_child
     8: 
     9: val fold_vars:
    10:   sym_state_t ->
    11:   usage_table_t * child_map_t * fully_bound_symbol_table_t ->
    12:   int ->
    13:   bparameter_t list ->
    14:   bexe_t list ->
    15:   bexe_t list
    16: 
    17: val add_use:
    18:   usage_table_t -> int -> int -> range_srcref -> unit
    19: 
End ocaml section to src/flx_foldvars.mli[1]
Start ocaml section to src/flx_foldvars.ml[1 /1 ]
     1: # 24 "./lpsrc/flx_foldvars.ipk"
     2: open Flx_util
     3: open Flx_ast
     4: open Flx_types
     5: open Flx_print
     6: open Flx_mtypes1
     7: open Flx_mtypes2
     8: open Flx_typing
     9: open Flx_mbind
    10: open Flx_srcref
    11: open List
    12: open Flx_unify
    13: open Flx_treg
    14: open Flx_generic
    15: open Flx_maps
    16: open Flx_exceptions
    17: open Flx_use
    18: open Flx_child
    19: open Flx_reparent
    20: open Flx_spexes
    21: 
    22: let string_of_intset s =
    23:   "{ " ^
    24:   IntSet.fold (fun i x -> x ^ si i ^ " ") s "" ^
    25:   "}"
    26: 
    27: 
    28: let ident x = x
    29: 
    30: let useset uses i =
    31:   let u = try Hashtbl.find uses i with Not_found -> [] in
    32:   fold_left (fun s (i,_) -> IntSet.add i s) IntSet.empty u
    33: 
    34: (* remove all uses of j from i *)
    35: let remove_uses uses i j =
    36:   (*
    37:   print_endline "Eliding " ^ si i ^ " from " ^ si j);
    38:   *)
    39:   try
    40:     let u = Hashtbl.find uses i in
    41:     let u = filter (fun (k,sr) -> j <> k) u in
    42:     Hashtbl.replace uses i u
    43:   with Not_found -> ()
    44: 
    45: let add_use uses i j sr =
    46:   let u = try Hashtbl.find uses i with Not_found -> [] in
    47:   Hashtbl.replace uses i ((j,sr) :: u)
    48: 
    49: 
    50: (* find all the variables of a function i which
    51:    are not used by children, this is the kids
    52:    minus just the union of everything used by the
    53:    child functions.
    54: *)
    55: let locals child_map uses i =
    56:   let kids = intset_of_list (find_children child_map i) in
    57:   (*
    58:   print_endline ("Kid of " ^ si i ^ " = " ^ string_of_intset kids);
    59:   *)
    60:   (*
    61:   let u = useset uses i in
    62:   *)
    63:   let u = Flx_call.child_use_closure kids uses i in
    64:   let unused_kids = IntSet.diff kids u in
    65:   (*
    66:   print_endline ("Unused kids are " ^ si i ^ " = " ^ string_of_intset unused_kids);
    67:   *)
    68:   let used_kids = IntSet.diff kids unused_kids in
    69:   (*
    70:   print_endline ("Used kids are " ^ si i ^ " = " ^ string_of_intset used_kids);
    71:   *)
    72:   (*
    73:   let desc = descendants child_map i in
    74:   *)
    75:   let desc =
    76:     IntSet.fold
    77:     (fun j s -> let u = descendants child_map j in IntSet.union u s)
    78:     used_kids
    79:     IntSet.empty
    80:   in
    81:   (*
    82:   print_endline ("Descendants of " ^ si i ^ " = " ^ string_of_intset desc);
    83:   *)
    84:   let u =
    85:     IntSet.fold
    86:     (fun j s ->
    87:       let u = useset uses j in
    88:       (*
    89:       print_endline ("Descendant " ^ si j ^ " of " ^ si i ^ " uses " ^ string_of_intset u);
    90:       *)
    91:       IntSet.union s u
    92:     )
    93:     desc
    94:     IntSet.empty
    95:   in
    96:   (*
    97:   print_endline ("Stuff used by some descendant = " ^ string_of_intset u);
    98:   *)
    99:   IntSet.diff kids u
   100: 
   101: 
   102: let fold_vars syms (uses,child_map,bbdfns) i ps exes =
   103:   let pset = fold_left (fun s {pindex=i}-> IntSet.add i s) IntSet.empty ps in
   104:   let kids = find_children child_map i in
   105:   let id,_,_,_ = Hashtbl.find bbdfns i in
   106:   (*
   107:   print_endline ("\nFOLDing " ^ id ^ "<" ^ si i ^">");
   108:   print_endline ("Kids = " ^ catmap ", " si kids);
   109:   *)
   110:   let descend = descendants child_map i in
   111:   (*
   112:   print_endline ("Descendants are " ^ string_of_intset descend);
   113:   *)
   114:   let locls = locals child_map uses i in
   115:   (*
   116:   print_endline ("Locals of " ^ si i ^ " are " ^ string_of_intset locls);
   117:   print_endline "INPUT Code is";
   118:   iter (fun exe -> print_endline (string_of_bexe syms.dfns 0 exe)) exes;
   119:   *)
   120: 
   121:   let elim_pass exes =
   122:     let count = ref 0 in
   123:     let rec find_tassign inexes outexes =
   124:       match inexes with
   125:       | [] -> rev outexes
   126:       | ((
   127:         `BEXE_init (_,j,y)
   128:         | `BEXE_assign (_, (`BEXPR_name (j,_),_),y)
   129:       ) as x) :: t  when IntSet.mem j locls ->
   130: 
   131:         let id,_,_,_ = Hashtbl.find bbdfns j in
   132:         (*
   133:         print_endline ("CONSIDERING VARIABLE " ^ id ^ "<" ^ si j ^ "> -> " ^ sbe syms.dfns y);
   134:         *)
   135:         (* does uses include initialisations or not ..?? *)
   136: 
   137:         (* check if the variable is used by any descendants *)
   138:         let nlocal_uses =
   139:           IntSet.fold
   140:           (fun child u ->
   141:              let luses = Flx_call.use_closure uses child in
   142:              u || IntSet.mem j luses
   143:           )
   144:           descend
   145:           false
   146:         in
   147:         if nlocal_uses then begin
   148:           (*
   149:           print_endline "VARIABLE USED NONLOCALLY";
   150:           *)
   151:           find_tassign t (x::outexes)
   152:         end else
   153: 
   154:         (* count all local uses of the variable: there are no others *)
   155:         let usecnt =
   156:           let luses = try Hashtbl.find uses i with Not_found -> [] in
   157:           fold_left (fun u (k,sr) -> if k = j then u+1 else u) 0 luses
   158:          in
   159:         (*
   160:         print_endline ("Use count = " ^ si usecnt);
   161:         *)
   162:         let setcnt = ref (if IntSet.mem j pset then 2 else 1) in
   163:         let sets exe =
   164:           match exe with
   165:            | `BEXE_init (_,k,_) when j = k -> incr setcnt
   166:            | _ -> ()
   167:         in
   168:         iter sets t; iter sets outexes;
   169:         (*
   170:         print_endline ("Set count = " ^ si !setcnt);
   171:         *)
   172:         let yuses = Flx_call.expr_uses syms descend uses pset y in
   173:         let delete_var () =
   174:           let id,_,_,_ = Hashtbl.find bbdfns j in
   175:           if syms.compiler_options.print_flag then
   176:             print_endline ("ELIMINATING VARIABLE " ^ id ^ "<" ^ si j ^ "> -> " ^ sbe syms.dfns y);
   177: 
   178:           (* remove the variable *)
   179:           Hashtbl.remove bbdfns j;
   180:           remove_child child_map i j;
   181:           remove_uses uses i j;
   182:           incr count
   183:         in
   184:         let isvar =
   185:           match Hashtbl.find bbdfns j with
   186:           | _,_,_,(`BBDCL_var _ | `BBDCL_tmp _ | `BBDCL_ref _ ) -> true
   187:           | _,_,_,`BBDCL_val _ -> false
   188:           | _ -> assert false
   189:         in
   190: 
   191:         (* Cannot do anything with variables or multiply assigned values
   192:           so skip to next instruction -- this is a tail-recursive call
   193:         *)
   194:         if isvar or !setcnt > 1 then begin
   195:           (*
   196:           print_endline "IS VAR or SETCNT > 1";
   197:           *)
   198:           find_tassign t (x::outexes)
   199: 
   200:         (* otherwise it is a value and it is set at most once *)
   201: 
   202:         (* it is not used anywhere (except the init) *)
   203:         end else if usecnt = 1 then begin
   204:           if syms.compiler_options.print_flag then
   205:           print_endline ("WARNING: unused variable "^si j^" found ..");
   206:           delete_var();
   207:           find_tassign t outexes
   208: 
   209:         (* OK, it is used at least once *)
   210:         end else
   211:         (* count elision of the init as 1 *)
   212:         let rplcnt = ref 1 in
   213:         let subi,rplimit =
   214:           match y with
   215:           | `BEXPR_tuple ys,_ ->
   216:             (*
   217:             print_endline "Tuple init found";
   218:             *)
   219:             let rec subi j ys e =
   220:               match map_tbexpr ident (subi j ys) ident e with
   221:               | `BEXPR_get_n (k, (`BEXPR_name(i,_),_) ),_
   222:                 when j = i ->
   223:                 (*
   224:                 print_endline ("Replacing " ^ sbe syms.dfns e);
   225:                 *)
   226:                 incr rplcnt; nth ys k
   227:               | x -> x
   228:             in subi j ys, length ys + 1
   229:           | _ ->
   230:             let rec subi j y e =
   231:               match map_tbexpr ident (subi j y) ident e with
   232:               | `BEXPR_name (i,_),_ when j = i -> incr rplcnt; y
   233:               | x -> x
   234:             in subi j y, 2 (* take init into account *)
   235:         in
   236:         let elimi exe =
   237:           map_bexe ident subi ident ident ident exe
   238:         in
   239:         let subs = ref true in
   240:         let elim exes = map
   241:           (fun exe ->
   242:           (*
   243:           print_endline ("In Exe = " ^ string_of_bexe syms.dfns 2 exe);
   244:           *)
   245:           if !subs then
   246:           match exe with
   247:           | `BEXE_axiom_check _ -> assert false
   248: 
   249:           (* terminate substitution, return unmodified instr *)
   250:           | `BEXE_goto _
   251:           | `BEXE_proc_return _
   252:           | `BEXE_label _
   253:              -> subs:= false; exe
   254: 
   255:           (* return unmodified instr *)
   256:           | `BEXE_begin
   257:           | `BEXE_end
   258:           | `BEXE_nop _
   259:           | `BEXE_code _
   260:           | `BEXE_nonreturn_code _
   261:           | `BEXE_comment _
   262:           | `BEXE_halt _
   263:              -> exe
   264: 
   265:           (* conditional, check if y depends on init (tail rec) *)
   266: 
   267:           | `BEXE_assign (_,(`BEXPR_name (k,_),_),_)
   268:           | `BEXE_svc (_,k)
   269:           | `BEXE_init (_,k,_) ->
   270:              subs := not (IntSet.mem k yuses);
   271:              elimi exe
   272: 
   273:           (* return modified instr *)
   274:           | `BEXE_ifgoto _
   275:           | `BEXE_ifnotgoto _
   276:           | `BEXE_assert _
   277:           | `BEXE_assert2 _
   278:              -> elimi exe
   279: 
   280:           (* terminate substitution, return modified instr *)
   281:           | `BEXE_apply_ctor _
   282:           | `BEXE_apply_ctor_stack _
   283:           | `BEXE_assign _
   284:           | `BEXE_fun_return _
   285:           | `BEXE_yield _
   286:           | `BEXE_jump _
   287:           | `BEXE_jump_direct _
   288:           | `BEXE_loop _
   289:           | `BEXE_call_prim _
   290:           | `BEXE_call _
   291:           | `BEXE_call_direct _
   292:           | `BEXE_call_method_direct _
   293:           | `BEXE_call_method_stack _
   294:           | `BEXE_call_stack _
   295:              -> subs := false; elimi exe
   296:           else exe
   297:           )
   298:           exes
   299:         in
   300:         let t' = elim t in
   301:         if !rplcnt > rplimit then
   302:           begin
   303:             if syms.compiler_options.print_flag then
   304:             print_endline (
   305:               "Warning: replacement count " ^
   306:               si !rplcnt ^
   307:               " exceeds replacement limit " ^
   308:               si rplimit
   309:             );
   310:             find_tassign t (x::outexes)
   311:           end
   312:         else if !rplcnt <> usecnt then
   313:           begin
   314:             if syms.compiler_options.print_flag then
   315:             print_endline (
   316:               "Warning: replacement count " ^
   317:               si !rplcnt ^
   318:               " not equal to usage count " ^
   319:               si usecnt
   320:             );
   321:             find_tassign t (x::outexes)
   322:           end
   323:         else
   324:           begin
   325:             delete_var();
   326:             (*
   327:             print_endline ("DELETE VAR "^si j^", ELIMINATING Exe = " ^ string_of_bexe syms.dfns 0 x);
   328:             *)
   329:             find_tassign t' outexes
   330:           end
   331: 
   332:       | h::t -> find_tassign t (h::outexes)
   333:     in
   334:     !count,find_tassign exes []
   335:   in
   336:   let master_count = ref 0 in
   337:   let iters = ref 0 in
   338:   let rec elim exes =
   339:     let count,exes = elim_pass exes in
   340:     incr iters;
   341:     master_count := !master_count + count;
   342:     if count > 0 then elim exes else exes
   343:   in
   344:   let exes = elim exes in
   345: 
   346:   (*
   347:   if syms.compiler_options.print_flag then
   348:   *)
   349:   if !master_count > 0 then begin
   350:     if syms.compiler_options.print_flag then
   351:     print_endline ("Removed " ^ si !master_count ^" variables in " ^ si !iters ^ " passes");
   352:     (*
   353:     print_endline "OUTPUT Code is";
   354:     iter (fun exe -> print_endline (string_of_bexe syms.dfns 0 exe)) exes;
   355:     *)
   356:   end
   357:   ;
   358:   exes
   359: 
   360: 
End ocaml section to src/flx_foldvars.ml[1]