5.49. Thread frame pointer required detector

Run after inlining is done. Uses two properies:
  `Uses_global_var
  `Requires_ptf
  `Not_requires_ptf
The first is a local property, whilst the second is its closure over abstract closure formation -- both explicit closure building and direct calls. The tfp is only required to reference global variables, to pass to constructors of function objects that do so, or to access the garbage collector.

Eliding it when not needed is a useful optimisation. The third property is the negation of the second.

Start ocaml section to src/flx_global.mli[1 /1 ]
     1: # 20 "./lpsrc/flx_global.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: open Flx_call
     7: 
     8: val set_globals:
     9:   sym_state_t ->
    10:   fully_bound_symbol_table_t ->
    11:   unit
    12: 
    13: val check_global_vars_all_used:
    14:   sym_state_t ->
    15:   fully_bound_symbol_table_t ->
    16:   (bid_t, 'a) Hashtbl.t -> unit
    17: 
End ocaml section to src/flx_global.mli[1]
Start ocaml section to src/flx_global.ml[1 /1 ]
     1: # 38 "./lpsrc/flx_global.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: 
    20: (* Garbage collector usage. The gc is required for non-stacked
    21:   procedure calls, applications, closure formations,
    22:   and variant constructors
    23: *)
    24: 
    25: let throw_on_gc syms bbdfns e : unit = match e with
    26:   | `BEXPR_closure (i,_),_ ->
    27:     (*
    28:     print_endline ("Found closure of " ^ si i);
    29:     *)
    30:     raise Not_found
    31: 
    32:   | `BEXPR_method_closure (_,i,_),_ ->
    33:     (*
    34:     print_endline ("Found method closure of " ^ si i);
    35:     *)
    36:     raise Not_found
    37: 
    38: 
    39:   | `BEXPR_apply_direct (i,_,_),_ -> raise Not_found
    40:   | `BEXPR_apply( (`BEXPR_closure (_,_),_),_),_ -> assert false
    41:   | `BEXPR_apply_struct (i,_,_),_ ->
    42:     let id,sr,parent,entry=Hashtbl.find bbdfns i in
    43:     begin match entry with
    44:     | `BBDCL_nonconst_ctor _ -> raise Not_found
    45:     | _ -> ()
    46:     end
    47: 
    48:   | `BEXPR_case (_,t),_ ->
    49:     begin match t with
    50:     | `BTYP_sum args when not (all_units args) -> raise Not_found
    51:     | `BTYP_inst (i,ts) ->
    52:       let id,parent,sr,entry = try Hashtbl.find bbdfns i with Not_found -> failwith "YIKES3" in
    53:       begin match entry with
    54:       | `BBDCL_union (vs,idts) when not (all_voids (map (fun (_,_,t)->t) idts)) -> raise Not_found
    55:       | _ -> ()
    56:       end
    57:     | _ -> ()
    58:     end
    59:   | _ -> ()
    60: 
    61: let expr_uses_gc syms bbdfns e =
    62:   (*
    63:   print_endline ("Check for gc in expr " ^ sbe syms.dfns e);
    64:   *)
    65:   iter_tbexpr ignore (throw_on_gc syms bbdfns) ignore e
    66: 
    67: let exe_uses_gc syms bbdfns exe =
    68:   (*
    69:   print_endline ("[exe_uses_gc] Exe = " ^ string_of_bexe syms.dfns 0 exe);
    70:   *)
    71:   match exe with
    72:   | `BEXE_jump_direct _
    73:   | `BEXE_call_direct _
    74:   | `BEXE_apply_ctor _
    75:     -> raise Not_found
    76: 
    77:   (* this test is used to trap use of gc by primitives *)
    78:   | `BEXE_call_prim (sr,i,ts,a) ->
    79:     let id,parent,sr,entry = Hashtbl.find bbdfns i in
    80:     begin match entry with
    81:     | `BBDCL_callback (props,vs,ps,_,_,`BTYP_void,rqs,_)
    82:     | `BBDCL_proc (props,vs,ps,_,rqs) ->
    83:       (*
    84:       print_endline "Checking primitive for gc use[2]";
    85:       *)
    86:       if mem `Uses_gc props
    87:       then begin (* print_endline "Flagged as using gc"; *) raise Not_found end
    88:       else
    89:       iter_bexe ignore (expr_uses_gc syms bbdfns) ignore ignore ignore exe
    90:     | _ -> assert false
    91:     end
    92: 
    93:   | _ ->
    94:     iter_bexe ignore (expr_uses_gc syms bbdfns) ignore ignore ignore exe
    95: 
    96: let exes_use_gc syms bbdfns exes =
    97:   try
    98:     iter (exe_uses_gc syms bbdfns) exes;
    99:     false
   100:   with
   101:     Not_found ->
   102:     (*
   103:     print_endline "GC USED HERE";
   104:     *)
   105:     true
   106: 
   107: let set_gc_use syms bbdfns =
   108:   Hashtbl.iter
   109:   (fun i (id,parent,sr,entry) -> match entry with
   110:   | `BBDCL_function (props,vs,ps,rt,exes) ->
   111:     if exes_use_gc syms bbdfns exes then
   112:     Hashtbl.replace bbdfns i (id,parent,sr,
   113:       `BBDCL_function (`Uses_gc :: props,vs,ps,rt,exes))
   114: 
   115:   | `BBDCL_procedure (props,vs,ps,exes) ->
   116:     if exes_use_gc syms bbdfns exes then
   117:     Hashtbl.replace bbdfns i (id,parent,sr,
   118:       `BBDCL_procedure (`Uses_gc :: props,vs,ps,exes))
   119: 
   120:   | `BBDCL_glr (props,vs,t, (pr,exes)) ->
   121:     if exes_use_gc syms bbdfns exes then
   122:     Hashtbl.replace bbdfns i (id,parent,sr,
   123:       `BBDCL_glr (`Uses_gc :: props,vs,t,(pr,exes)))
   124: 
   125:   | `BBDCL_regmatch (props,vs,ps,rt, (a,s,se,tr)) ->
   126:     begin
   127:       try
   128:         Hashtbl.iter (fun _ e -> expr_uses_gc syms bbdfns e) se
   129:       with Not_found ->
   130:         Hashtbl.replace bbdfns i (id,parent,sr,
   131:           `BBDCL_regmatch (`Uses_gc :: props,vs,ps,rt,(a,s,se,tr)))
   132:     end
   133: 
   134:   | `BBDCL_reglex (props,vs, ps, j,rt, (a,s,se,tr)) ->
   135:     begin
   136:       try
   137:         Hashtbl.iter (fun _ e -> expr_uses_gc syms bbdfns e) se
   138:       with Not_found ->
   139:         Hashtbl.replace bbdfns i (id,parent,sr,
   140:           `BBDCL_reglex (`Uses_gc :: props,vs,ps,j,rt,(a,s,se,tr)))
   141:     end
   142: 
   143:   | _ -> ()
   144:   )
   145:   bbdfns
   146: 
   147: 
   148: let is_global_var bbdfns i =
   149:   let id,parent,sr,entry = try Hashtbl.find bbdfns i with Not_found -> failwith "YIKES1" in
   150:   match entry with
   151:   | `BBDCL_var _
   152:   | `BBDCL_val _ when (match parent with None -> true | _ -> false ) -> true
   153:   | _ -> false
   154: 
   155: let throw_on_global bbdfns i =
   156:   if is_global_var bbdfns i then raise Not_found
   157: 
   158: let expr_uses_global bbdfns e =
   159:   iter_tbexpr (throw_on_global bbdfns) ignore ignore e
   160: 
   161: let exe_uses_global bbdfns exe =
   162:   iter_bexe (throw_on_global bbdfns) (expr_uses_global bbdfns) ignore ignore ignore exe
   163: 
   164: let exes_use_global bbdfns exes =
   165:   try
   166:     iter (exe_uses_global bbdfns) exes;
   167:     false
   168:   with Not_found -> true
   169: 
   170: let set_local_globals bbdfns =
   171:   Hashtbl.iter
   172:   (fun i (id,parent,sr,entry) -> match entry with
   173:   | `BBDCL_function (props,vs,ps,rt,exes) ->
   174:     if exes_use_global bbdfns exes then
   175:     Hashtbl.replace bbdfns i (id,parent,sr,
   176:       `BBDCL_function (`Uses_global_var :: props,vs,ps,rt,exes))
   177: 
   178:   | `BBDCL_procedure (props,vs,ps,exes) ->
   179:     if exes_use_global bbdfns exes then
   180:     Hashtbl.replace bbdfns i (id,parent,sr,
   181:       `BBDCL_procedure (`Uses_global_var :: props,vs,ps,exes))
   182: 
   183:   | `BBDCL_glr (props,vs,t, (pr,exes)) ->
   184:     if exes_use_global bbdfns exes then
   185:     Hashtbl.replace bbdfns i (id,parent,sr,
   186:       `BBDCL_glr (`Uses_global_var :: props,vs,t,(pr,exes)))
   187: 
   188:   | `BBDCL_regmatch (props,vs,ps,rt, (a,s,se,tr)) ->
   189:     begin
   190:       try
   191:         Hashtbl.iter (fun _ e -> expr_uses_global bbdfns e) se
   192:       with Not_found ->
   193:         Hashtbl.replace bbdfns i (id,parent,sr,
   194:           `BBDCL_regmatch (`Uses_global_var :: props,vs,ps,rt,(a,s,se,tr)))
   195:     end
   196: 
   197:   | `BBDCL_reglex (props,vs, ps, j,rt, (a,s,se,tr)) ->
   198:     begin
   199:       try
   200:         Hashtbl.iter (fun _ e -> expr_uses_global bbdfns e) se
   201:       with Not_found ->
   202:         Hashtbl.replace bbdfns i (id,parent,sr,
   203:           `BBDCL_reglex (`Uses_global_var :: props,vs,ps,j,rt,(a,s,se,tr)))
   204:     end
   205: 
   206:    | _ -> ()
   207:   )
   208:   bbdfns
   209: 
   210: type ptf_required = | Required | Not_required | Unknown
   211: 
   212: let rec set_ptf_usage syms bbdfns usage excludes i =
   213: 
   214:   (* cal reqs for functions we call and fold together *)
   215:   let cal_reqs calls i : ptf_required * property_t =
   216:     let result1 =
   217:       fold_left
   218:       (fun u (j,_) ->
   219:         let r = set_ptf_usage syms bbdfns usage (i::excludes) j in
   220:           begin match u,r with
   221:           | Unknown, x | x, Unknown -> x
   222:           | Required, _ | _, Required -> Required
   223:           | Not_required, _ (* | _, Not_required *) -> Not_required
   224:           end
   225:         )
   226:         Not_required
   227:         calls
   228:     in
   229:     let result2 =
   230:       match result1 with
   231:       | Required -> `Requires_ptf
   232:       | Not_required -> `Not_requires_ptf
   233:       | _ -> assert false
   234:     in
   235:     result1, result2
   236:   in
   237: 
   238:   if mem i excludes then Unknown else
   239: 
   240:   (* main routine *)
   241:   let calls = try Hashtbl.find usage i with Not_found -> [] in
   242: 
   243:   let id,parent,sr,entry =  try Hashtbl.find bbdfns i with Not_found -> failwith ("YIKES2 -- " ^ si i) in
   244:   match entry with
   245:   | `BBDCL_function (props,vs,ps,rt,exes) ->
   246:     if mem `Requires_ptf props then Required
   247:     else if mem `Not_requires_ptf props then Not_required
   248:     else if mem `Uses_global_var props or mem `Uses_gc props or mem `Heap_closure props then begin
   249:       Hashtbl.replace bbdfns i (id,parent,sr,
   250:         `BBDCL_function (`Requires_ptf :: props,vs,ps,rt,exes));
   251:         Required
   252:     end else begin
   253:       let result1, result2 = cal_reqs calls i in
   254:       Hashtbl.replace bbdfns i (id,parent,sr,
   255:         `BBDCL_function (result2 :: props,vs,ps,rt,exes));
   256:       result1
   257:    end
   258: 
   259:   | `BBDCL_procedure (props,vs,ps,exes) ->
   260:     if mem `Requires_ptf props then Required
   261:     else if mem `Not_requires_ptf props then Not_required
   262:     else if mem `Uses_global_var props or mem `Uses_gc props or mem `Heap_closure props then begin
   263:       Hashtbl.replace bbdfns i (id,parent,sr,
   264:         `BBDCL_procedure (`Requires_ptf :: props,vs,ps,exes));
   265:         Required
   266:     end else begin
   267:       let result1, result2 = cal_reqs calls i in
   268:       Hashtbl.replace bbdfns i (id,parent,sr,
   269:         `BBDCL_procedure (result2 :: props,vs,ps,exes));
   270:       result1
   271:    end
   272: 
   273:   | `BBDCL_proc (props,vs,ps,ct,reqs) ->
   274:     if mem `Requires_ptf props then Required
   275:     else if mem `Not_requires_ptf props then Not_required
   276:     else if mem `Uses_global_var props or mem `Uses_gc props or mem `Heap_closure props then begin
   277:       Hashtbl.replace bbdfns i (id,parent,sr,
   278:         `BBDCL_proc (`Requires_ptf :: props,vs,ps,ct,reqs));
   279:         Required
   280:     end else Not_required
   281: 
   282:   | `BBDCL_glr (props,vs,t, (pr,exes)) ->
   283:     if mem `Requires_ptf props then Required
   284:     else if mem `Not_requires_ptf props then Not_required
   285:     else if mem `Uses_global_var props or mem `Uses_gc props or mem `Heap_closure props then begin
   286:       Hashtbl.replace bbdfns i (id,parent,sr,
   287:         `BBDCL_glr (`Requires_ptf :: props,vs,t,(pr,exes)));
   288:         Required
   289:     end else begin
   290:       let result1, result2 = cal_reqs calls i in
   291:       Hashtbl.replace bbdfns i (id,parent,sr,
   292:         `BBDCL_glr (result2 :: props,vs,t,(pr,exes)));
   293:       result1
   294:    end
   295: 
   296:   | `BBDCL_regmatch (props,vs,ps,rt,ra) ->
   297:     if mem `Requires_ptf props then Required
   298:     else if mem `Not_requires_ptf props then Not_required
   299:     else if mem `Uses_global_var props or mem `Uses_gc props or mem `Heap_closure props then begin
   300:       Hashtbl.replace bbdfns i (id,parent,sr,
   301:         `BBDCL_regmatch(`Requires_ptf :: props,vs,ps,rt,ra));
   302:         Required
   303:     end else begin
   304:       let result1, result2 = cal_reqs calls i in
   305:       Hashtbl.replace bbdfns i (id,parent,sr,
   306:         `BBDCL_regmatch (result2 :: props,vs,ps,rt,ra));
   307:       result1
   308:    end
   309: 
   310:   | `BBDCL_reglex (props,vs, ps,j,rt,ra) ->
   311:     if mem `Requires_ptf props then Required
   312:     else if mem `Not_requires_ptf props then Not_required
   313:     else if mem `Uses_global_var props or mem `Uses_gc props or mem `Heap_closure props then begin
   314:       Hashtbl.replace bbdfns i (id,parent,sr,
   315:         `BBDCL_reglex (`Requires_ptf :: props,vs,ps,j,rt,ra));
   316:         Required
   317:     end else begin
   318:       let result1, result2 = cal_reqs calls i in
   319:       Hashtbl.replace bbdfns i (id,parent,sr,
   320:         `BBDCL_reglex (result2 :: props,vs,ps,j,rt,ra));
   321:       result1
   322:    end
   323: 
   324:   | `BBDCL_class (props,vs) ->
   325:     if mem `Requires_ptf props then Required
   326:     else if mem `Not_requires_ptf props then Not_required
   327:     else if mem `Uses_global_var props or mem `Uses_gc props or mem `Heap_closure props then begin
   328:       Hashtbl.replace bbdfns i (id,parent,sr,
   329:         `BBDCL_class (`Requires_ptf :: props,vs));
   330:         Required
   331:     end else begin
   332:       let result1, result2 = cal_reqs calls i in
   333:       Hashtbl.replace bbdfns i (id,parent,sr,
   334:         `BBDCL_class (result2 :: props,vs));
   335:       result1
   336:    end
   337: 
   338:   | _ -> Not_required
   339: 
   340: let set_globals syms bbdfns =
   341:   set_local_globals bbdfns;
   342:   set_gc_use syms bbdfns;
   343: 
   344:   let usage = match Flx_call.call_data syms bbdfns with u,_ -> u in
   345:   Hashtbl.iter
   346:   (fun i _ -> ignore (set_ptf_usage syms bbdfns usage [] i))
   347:   bbdfns
   348: 
   349: let find_global_vars syms bbdfns =
   350:   let gvars = ref IntSet.empty in
   351:   Hashtbl.iter
   352:   (fun i _ -> if is_global_var bbdfns i then gvars := IntSet.add i !gvars)
   353:   bbdfns
   354:   ;
   355:   !gvars
   356: 
   357: let check_used syms bbdfns used i =
   358:   Hashtbl.mem used i
   359: 
   360: let check_all_used syms bbdfns used ii =
   361:   let all_used = ref true in
   362:   IntSet.iter (fun i-> if not (check_used syms bbdfns used i)
   363:     then begin
   364:       print_endline ("FOUND UNUSED VARIABLE " ^ si i);
   365:       all_used := false
   366:     end
   367:   )
   368:   ii
   369:   ;
   370:   if !all_used then
   371:     print_endline "ALL GLOBAL VARS ARE USED"
   372:   else
   373:     print_endline "Som UNUSED vars!"
   374: 
   375: let check_global_vars_all_used syms bbdfns used =
   376:   let ii = find_global_vars syms bbdfns in
   377:   check_all_used syms bbdfns used ii
   378: 
End ocaml section to src/flx_global.ml[1]