5.57. 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 ptf 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 _,_ -> raise Not_found
    40:   | `BEXPR_apply_method_direct _,_ -> raise Not_found
    41:   | `BEXPR_apply( (`BEXPR_closure (_,_),_),_),_ -> raise Not_found
    42:   | `BEXPR_apply_struct (i,_,_),_ ->
    43:     let id,sr,parent,entry=Hashtbl.find bbdfns i in
    44:     begin match entry with
    45:     | `BBDCL_nonconst_ctor _ -> raise Not_found
    46:     | _ -> ()
    47:     end
    48: 
    49:   | `BEXPR_case (_,t),_ ->
    50:     begin match t with
    51:     | `BTYP_sum args when not (all_units args) -> raise Not_found
    52:     | `BTYP_inst (i,ts) ->
    53:       let id,parent,sr,entry = try Hashtbl.find bbdfns i with Not_found -> failwith "YIKES3" in
    54:       begin match entry with
    55:       | `BBDCL_union (vs,idts) when not (all_voids (map (fun (_,_,t)->t) idts)) -> raise Not_found
    56:       | _ -> ()
    57:       end
    58:     | _ -> ()
    59:     end
    60:   | _ -> ()
    61: 
    62: let expr_uses_gc syms bbdfns e =
    63:   (*
    64:   print_endline ("Check for gc in expr " ^ sbe syms.dfns e);
    65:   *)
    66:   iter_tbexpr ignore (throw_on_gc syms bbdfns) ignore e
    67: 
    68: let exe_uses_gc syms bbdfns exe =
    69:   (*
    70:   print_endline ("[exe_uses_gc] Exe = " ^ string_of_bexe syms.dfns 0 exe);
    71:   *)
    72:   match exe with
    73:   | `BEXE_jump_direct _
    74:   | `BEXE_call_direct _
    75:   | `BEXE_apply_ctor _
    76:     -> raise Not_found
    77: 
    78:   (* this test is used to trap use of gc by primitives *)
    79:   | `BEXE_call_prim (sr,i,ts,a) ->
    80:     let id,parent,sr,entry = Hashtbl.find bbdfns i in
    81:     begin match entry with
    82:     | `BBDCL_callback (props,vs,ps,_,_,`BTYP_void,rqs,_)
    83:     | `BBDCL_proc (props,vs,ps,_,rqs) ->
    84:       (*
    85:       print_endline "Checking primitive for gc use[2]";
    86:       *)
    87:       if mem `Uses_gc props
    88:       then begin (* print_endline "Flagged as using gc"; *) raise Not_found end
    89:       else
    90:       iter_bexe ignore (expr_uses_gc syms bbdfns) ignore ignore ignore exe
    91:     | _ ->
    92:       print_endline ("Call primitive to non-primitive " ^ id ^ "<"^ si i^ ">");
    93:       assert false
    94:     end
    95: 
    96:   | _ ->
    97:     iter_bexe ignore (expr_uses_gc syms bbdfns) ignore ignore ignore exe
    98: 
    99: let exes_use_gc syms bbdfns exes =
   100:   try
   101:     iter (exe_uses_gc syms bbdfns) exes;
   102:     false
   103:   with
   104:     Not_found ->
   105:     (*
   106:     print_endline "GC USED HERE";
   107:     *)
   108:     true
   109: 
   110: let exe_uses_yield exe =
   111:   match exe with
   112:   | `BEXE_yield _ -> raise Not_found
   113:   | _ -> ()
   114: 
   115: let exes_use_yield exes =
   116:   try
   117:     iter exe_uses_yield exes;
   118:     false
   119:   with
   120:     Not_found ->
   121:     (*
   122:     print_endline "YIELD USED HERE";
   123:     *)
   124:     true
   125: 
   126: (* ALSO calculates if a function uses a yield *)
   127: let set_gc_use syms bbdfns =
   128:   Hashtbl.iter
   129:   (fun i (id,parent,sr,entry) -> match entry with
   130:   | `BBDCL_function (props,vs,ps,rt,exes) ->
   131:     let uses_gc = exes_use_gc syms bbdfns exes in
   132:     let uses_yield = exes_use_yield exes in
   133:     let props = if uses_gc then `Uses_gc :: props else props in
   134:     let props = if uses_yield then `Heap_closure :: `Yields :: `Generator :: props else props in
   135:     if uses_gc or uses_yield
   136:     then
   137:     Hashtbl.replace bbdfns i (id,parent,sr,
   138:       `BBDCL_function (`Uses_gc :: props,vs,ps,rt,exes))
   139: 
   140:   | `BBDCL_procedure (props,vs,ps,exes) ->
   141:     if exes_use_gc syms bbdfns exes then
   142:     Hashtbl.replace bbdfns i (id,parent,sr,
   143:       `BBDCL_procedure (`Uses_gc :: props,vs,ps,exes))
   144: 
   145:   | `BBDCL_glr (props,vs,t, (pr,exes)) ->
   146:     if exes_use_gc syms bbdfns exes then
   147:     Hashtbl.replace bbdfns i (id,parent,sr,
   148:       `BBDCL_glr (`Uses_gc :: props,vs,t,(pr,exes)))
   149: 
   150:   | `BBDCL_regmatch (props,vs,ps,rt, (a,s,se,tr)) ->
   151:     begin
   152:       try
   153:         Hashtbl.iter (fun _ e -> expr_uses_gc syms bbdfns e) se
   154:       with Not_found ->
   155:         Hashtbl.replace bbdfns i (id,parent,sr,
   156:           `BBDCL_regmatch (`Uses_gc :: props,vs,ps,rt,(a,s,se,tr)))
   157:     end
   158: 
   159:   | `BBDCL_reglex (props,vs, ps, j,rt, (a,s,se,tr)) ->
   160:     begin
   161:       try
   162:         Hashtbl.iter (fun _ e -> expr_uses_gc syms bbdfns e) se
   163:       with Not_found ->
   164:         Hashtbl.replace bbdfns i (id,parent,sr,
   165:           `BBDCL_reglex (`Uses_gc :: props,vs,ps,j,rt,(a,s,se,tr)))
   166:     end
   167: 
   168:   | _ -> ()
   169:   )
   170:   bbdfns
   171: 
   172: 
   173: let is_global_var bbdfns i =
   174:   let id,parent,sr,entry = try Hashtbl.find bbdfns i with Not_found -> failwith "YIKES1" in
   175:   match entry with
   176:   | `BBDCL_var _
   177:   | `BBDCL_val _ when (match parent with None -> true | _ -> false ) -> true
   178:   | _ -> false
   179: 
   180: let throw_on_global bbdfns i =
   181:   if is_global_var bbdfns i then raise Not_found
   182: 
   183: let expr_uses_global bbdfns e =
   184:   iter_tbexpr (throw_on_global bbdfns) ignore ignore e
   185: 
   186: let exe_uses_global bbdfns exe =
   187:   iter_bexe (throw_on_global bbdfns) (expr_uses_global bbdfns) ignore ignore ignore exe
   188: 
   189: let exes_use_global bbdfns exes =
   190:   try
   191:     iter (exe_uses_global bbdfns) exes;
   192:     false
   193:   with Not_found -> true
   194: 
   195: let set_local_globals bbdfns =
   196:   Hashtbl.iter
   197:   (fun i (id,parent,sr,entry) -> match entry with
   198:   | `BBDCL_function (props,vs,ps,rt,exes) ->
   199:     if exes_use_global bbdfns exes then
   200:     Hashtbl.replace bbdfns i (id,parent,sr,
   201:       `BBDCL_function (`Uses_global_var :: props,vs,ps,rt,exes))
   202: 
   203:   | `BBDCL_procedure (props,vs,ps,exes) ->
   204:     if exes_use_global bbdfns exes then
   205:     Hashtbl.replace bbdfns i (id,parent,sr,
   206:       `BBDCL_procedure (`Uses_global_var :: props,vs,ps,exes))
   207: 
   208:   | `BBDCL_glr (props,vs,t, (pr,exes)) ->
   209:     if exes_use_global bbdfns exes then
   210:     Hashtbl.replace bbdfns i (id,parent,sr,
   211:       `BBDCL_glr (`Uses_global_var :: props,vs,t,(pr,exes)))
   212: 
   213:   | `BBDCL_regmatch (props,vs,ps,rt, (a,s,se,tr)) ->
   214:     begin
   215:       try
   216:         Hashtbl.iter (fun _ e -> expr_uses_global bbdfns e) se
   217:       with Not_found ->
   218:         Hashtbl.replace bbdfns i (id,parent,sr,
   219:           `BBDCL_regmatch (`Uses_global_var :: props,vs,ps,rt,(a,s,se,tr)))
   220:     end
   221: 
   222:   | `BBDCL_reglex (props,vs, ps, j,rt, (a,s,se,tr)) ->
   223:     begin
   224:       try
   225:         Hashtbl.iter (fun _ e -> expr_uses_global bbdfns e) se
   226:       with Not_found ->
   227:         Hashtbl.replace bbdfns i (id,parent,sr,
   228:           `BBDCL_reglex (`Uses_global_var :: props,vs,ps,j,rt,(a,s,se,tr)))
   229:     end
   230: 
   231:    | _ -> ()
   232:   )
   233:   bbdfns
   234: 
   235: type ptf_required = | Required | Not_required | Unknown
   236: 
   237: let rec set_ptf_usage syms bbdfns usage excludes i =
   238: 
   239:   (* cal reqs for functions we call and fold together *)
   240:   let cal_reqs calls i : ptf_required * property_t =
   241:     let result1 =
   242:       fold_left
   243:       (fun u (j,_) ->
   244:         let r = set_ptf_usage syms bbdfns usage (i::excludes) j in
   245:           (*
   246:           print_endline ("Call of " ^ si i^ " to " ^ si j ^ " PTF of j " ^ (
   247:             match r with
   248:             | Unknown -> "UNKNOWN"
   249:             | Required -> "REQUIRED"
   250:             | Not_required -> "NOT REQUIRED"
   251:           ));
   252:           *)
   253: 
   254:           begin match u,r with
   255:           | Unknown, x | x, Unknown -> x
   256:           | Required, _ | _, Required -> Required
   257:           | Not_required, _ (* | _, Not_required *) -> Not_required
   258:           end
   259:         )
   260:         Not_required
   261:         calls
   262:     in
   263:     let result2 =
   264:       match result1 with
   265:       | Required -> `Requires_ptf
   266:       | Not_required -> `Not_requires_ptf
   267:       | _ -> assert false
   268:     in
   269:     result1, result2
   270:   in
   271: 
   272:   if mem i excludes then Unknown else
   273: 
   274:   (* main routine *)
   275:   let calls = try Hashtbl.find usage i with Not_found -> [] in
   276: 
   277:   let id,parent,sr,entry =  try Hashtbl.find bbdfns i with Not_found -> failwith ("YIKES2 -- " ^ si i) in
   278:   match entry with
   279:   | `BBDCL_function (props,vs,ps,rt,exes) ->
   280:     (*
   281:     print_endline ("Function " ^ id ^ "<"^si i^"> properties " ^ string_of_properties props);
   282:     *)
   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_function (`Requires_ptf :: props,vs,ps,rt,exes));
   288:         Required
   289:     end else begin
   290:       let result1, result2 = cal_reqs calls i in
   291:       (*
   292:       print_endline ("Function " ^ id ^ " ADDING properties " ^ string_of_properties [result2]);
   293:       *)
   294:       Hashtbl.replace bbdfns i (id,parent,sr,
   295:         `BBDCL_function (result2 :: props,vs,ps,rt,exes));
   296:       result1
   297:    end
   298: 
   299:   | `BBDCL_procedure (props,vs,ps,exes) ->
   300:     if mem `Requires_ptf props then Required
   301:     else if mem `Not_requires_ptf props then Not_required
   302:     else if mem `Uses_global_var props or mem `Uses_gc props or mem `Heap_closure props then begin
   303:       Hashtbl.replace bbdfns i (id,parent,sr,
   304:         `BBDCL_procedure (`Requires_ptf :: props,vs,ps,exes));
   305:         Required
   306:     end else begin
   307:       let result1, result2 = cal_reqs calls i in
   308:       Hashtbl.replace bbdfns i (id,parent,sr,
   309:         `BBDCL_procedure (result2 :: props,vs,ps,exes));
   310:       result1
   311:    end
   312: 
   313:   | `BBDCL_proc (props,vs,ps,ct,reqs) ->
   314:     if mem `Requires_ptf props then Required
   315:     else if mem `Not_requires_ptf props then Not_required
   316:     else if mem `Uses_global_var props or mem `Uses_gc props or mem `Heap_closure props then begin
   317:       Hashtbl.replace bbdfns i (id,parent,sr,
   318:         `BBDCL_proc (`Requires_ptf :: props,vs,ps,ct,reqs));
   319:         Required
   320:     end else Not_required
   321: 
   322:   | `BBDCL_fun (props,vs,ps,ret,ct,reqs,prec) ->
   323:     (*
   324:     print_endline ("Fun " ^ id ^ "<"^si i^"> properties " ^ string_of_properties props);
   325:     *)
   326:     if mem `Requires_ptf props then Required
   327:     else if mem `Not_requires_ptf props then Not_required
   328:     else if mem `Uses_global_var props or mem `Uses_gc props or mem `Heap_closure props then begin
   329:       Hashtbl.replace bbdfns i (id,parent,sr,
   330:         `BBDCL_fun (`Requires_ptf :: props,vs,ps,ret,ct,reqs,prec));
   331:         Required
   332:     end else Not_required
   333: 
   334:   | `BBDCL_glr (props,vs,t, (pr,exes)) ->
   335:     if mem `Requires_ptf props then Required
   336:     else if mem `Not_requires_ptf props then Not_required
   337:     else if mem `Uses_global_var props or mem `Uses_gc props or mem `Heap_closure props then begin
   338:       Hashtbl.replace bbdfns i (id,parent,sr,
   339:         `BBDCL_glr (`Requires_ptf :: props,vs,t,(pr,exes)));
   340:         Required
   341:     end else begin
   342:       let result1, result2 = cal_reqs calls i in
   343:       Hashtbl.replace bbdfns i (id,parent,sr,
   344:         `BBDCL_glr (result2 :: props,vs,t,(pr,exes)));
   345:       result1
   346:    end
   347: 
   348:   | `BBDCL_regmatch (props,vs,ps,rt,ra) ->
   349:     if mem `Requires_ptf props then Required
   350:     else if mem `Not_requires_ptf props then Not_required
   351:     else if mem `Uses_global_var props or mem `Uses_gc props or mem `Heap_closure props then begin
   352:       Hashtbl.replace bbdfns i (id,parent,sr,
   353:         `BBDCL_regmatch(`Requires_ptf :: props,vs,ps,rt,ra));
   354:         Required
   355:     end else begin
   356:       let result1, result2 = cal_reqs calls i in
   357:       Hashtbl.replace bbdfns i (id,parent,sr,
   358:         `BBDCL_regmatch (result2 :: props,vs,ps,rt,ra));
   359:       result1
   360:    end
   361: 
   362:   | `BBDCL_reglex (props,vs, ps,j,rt,ra) ->
   363:     if mem `Requires_ptf props then Required
   364:     else if mem `Not_requires_ptf props then Not_required
   365:     else if mem `Uses_global_var props or mem `Uses_gc props or mem `Heap_closure props then begin
   366:       Hashtbl.replace bbdfns i (id,parent,sr,
   367:         `BBDCL_reglex (`Requires_ptf :: props,vs,ps,j,rt,ra));
   368:         Required
   369:     end else begin
   370:       let result1, result2 = cal_reqs calls i in
   371:       Hashtbl.replace bbdfns i (id,parent,sr,
   372:         `BBDCL_reglex (result2 :: props,vs,ps,j,rt,ra));
   373:       result1
   374:    end
   375: 
   376:   | `BBDCL_class (props,vs) ->
   377:     if mem `Requires_ptf props then Required
   378:     else if mem `Not_requires_ptf props then Not_required
   379:     else if mem `Uses_global_var props or mem `Uses_gc props or mem `Heap_closure props then begin
   380:       Hashtbl.replace bbdfns i (id,parent,sr,
   381:         `BBDCL_class (`Requires_ptf :: props,vs));
   382:         Required
   383:     end else begin
   384:       let result1, result2 = cal_reqs calls i in
   385:       Hashtbl.replace bbdfns i (id,parent,sr,
   386:         `BBDCL_class (result2 :: props,vs));
   387:       result1
   388:    end
   389: 
   390:   | _ -> Not_required
   391: 
   392: let set_globals syms bbdfns =
   393:   set_local_globals bbdfns;
   394:   set_gc_use syms bbdfns;
   395: 
   396:   let usage = match Flx_call.call_data syms bbdfns with u,_ -> u in
   397:   Hashtbl.iter
   398:   (fun i _ -> ignore (set_ptf_usage syms bbdfns usage [] i))
   399:   bbdfns
   400: 
   401: let find_global_vars syms bbdfns =
   402:   let gvars = ref IntSet.empty in
   403:   Hashtbl.iter
   404:   (fun i _ -> if is_global_var bbdfns i then gvars := IntSet.add i !gvars)
   405:   bbdfns
   406:   ;
   407:   !gvars
   408: 
   409: let check_used syms bbdfns used i =
   410:   Hashtbl.mem used i
   411: 
   412: let check_all_used syms bbdfns used ii =
   413:   let all_used = ref true in
   414:   IntSet.iter (fun i-> if not (check_used syms bbdfns used i)
   415:     then begin
   416:       print_endline ("FOUND UNUSED VARIABLE " ^ si i);
   417:       all_used := false
   418:     end
   419:   )
   420:   ii
   421:   ;
   422:   if !all_used then
   423:     print_endline "ALL GLOBAL VARS ARE USED"
   424:   else
   425:     print_endline "Som UNUSED vars!"
   426: 
   427: let check_global_vars_all_used syms bbdfns used =
   428:   let ii = find_global_vars syms bbdfns in
   429:   check_all_used syms bbdfns used ii
   430: 
End ocaml section to src/flx_global.ml[1]