`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 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.
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 _,_ -> 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: