`Uses_global_var `Requires_ptf `Not_requires_ptfThe 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.
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:
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: