1: # 4 "./lpsrc/flx_label.ipk" 2: open Flx_ast 3: open Flx_types 4: open Flx_mtypes2 5: 6: type label_map_t = 7: (bid_t,(string, int) Hashtbl.t) Hashtbl.t 8: 9: val create_label_map: 10: fully_bound_symbol_table_t -> 11: int ref -> 12: label_map_t 13: 14: type goto_kind_t = 15: [ 16: | `Local of int (* index *) 17: | `Nonlocal of int * int (* index, parent *) 18: | `Unreachable 19: ] 20: 21: val find_label: 22: fully_bound_symbol_table_t -> 23: label_map_t -> 24: int -> 25: string -> 26: goto_kind_t 27: 28: type label_kind_t = [`Far | `Near | `Unused] 29: 30: type label_usage_t = (int,label_kind_t) Hashtbl.t 31: 32: val create_label_usage: 33: sym_state_t -> 34: fully_bound_symbol_table_t -> 35: label_map_t -> 36: label_usage_t 37: 38: val get_label_kind: 39: label_map_t -> 40: label_usage_t -> 41: bid_t -> (* container *) 42: string -> (* label *) 43: label_kind_t 44: 45: val get_label_kind_from_index: 46: label_usage_t -> 47: int -> 48: label_kind_t 49:
1: # 54 "./lpsrc/flx_label.ipk" 2: open Flx_types 3: open Flx_ast 4: open Flx_mtypes2 5: open Flx_exceptions 6: open List 7: open Flx_util 8: open Flx_print 9: 10: type label_map_t = 11: (bid_t,(string, int) Hashtbl.t) Hashtbl.t 12: 13: type label_kind_t = [`Far | `Near | `Unused] 14: 15: type label_usage_t = (int,label_kind_t) Hashtbl.t 16: 17: type goto_kind_t = 18: [ 19: | `Local of int 20: | `Nonlocal of int * int 21: | `Unreachable 22: ] 23: 24: let get_labels bbdfns counter exes = 25: let labels = Hashtbl.create 97 in 26: List.iter 27: (fun exe -> match exe with 28: | `BEXE_label (_,s) -> 29: (* 30: print_endline ("Label " ^ s); 31: *) 32: Hashtbl.add labels s !counter; incr counter 33: | _ -> () 34: ) 35: exes 36: ; 37: labels 38: 39: let create_label_map bbdfns counter = 40: (* 41: print_endline "Creating label map"; 42: *) 43: let label_map = Hashtbl.create 97 in 44: Hashtbl.iter 45: (fun index (id,parent,sr,entry) -> 46: (* 47: print_endline ("Routine " ^ id ^ "<"^ si index ^">"); 48: *) 49: match entry with 50: | `BBDCL_function (_,_,_,_,exes) -> 51: Hashtbl.add label_map index (get_labels bbdfns counter exes) 52: | `BBDCL_procedure (_,_,_,exes) -> 53: Hashtbl.add label_map index (get_labels bbdfns counter exes) 54: | _ -> () 55: ) 56: bbdfns 57: ; 58: label_map 59: 60: 61: let rec find_label bbdfns label_map caller label = 62: let labels = Hashtbl.find label_map caller in 63: try `Local (Hashtbl.find labels label) 64: with Not_found -> 65: let id,parent,sr,entry = Hashtbl.find bbdfns caller in 66: match entry with 67: | `BBDCL_function _ -> `Unreachable 68: | `BBDCL_procedure _ -> 69: begin match parent with None -> `Unreachable 70: | Some parent -> 71: begin match find_label bbdfns label_map parent label with 72: | `Local i -> `Nonlocal (i,parent) 73: | x -> x 74: end 75: end 76: | _ -> assert false 77: 78: let get_label_kind_from_index usage lix = 79: try Hashtbl.find usage lix with Not_found -> `Unused 80: 81: let get_label_kind label_map usage_map proc label = 82: let labels = Hashtbl.find label_map proc in 83: let lix = Hashtbl.find labels label in 84: get_label_kind_from_index usage_map lix 85: 86: 87: let cal_usage syms bbdfns label_map caller exes usage = 88: iter 89: (function 90: | `BEXE_goto (sr,label) 91: | `BEXE_ifgoto (sr,_,label) 92: | `BEXE_ifnotgoto (sr,_,label) -> 93: begin match find_label bbdfns label_map caller label with 94: | `Unreachable -> 95: syserr sr ("[flx_label] Caller "^si caller^" Jump to unreachable label " ^ label ^ "\n" ^ 96: (catmap "\n" (string_of_bexe syms.dfns 2) exes)) 97: | `Local lix -> 98: begin match get_label_kind_from_index usage lix with 99: | `Unused -> Hashtbl.replace usage lix `Near 100: | `Near | `Far -> () 101: end 102: | `Nonlocal (lix,_) -> 103: begin match get_label_kind_from_index usage lix with 104: | `Unused | `Near -> Hashtbl.replace usage lix `Far 105: | `Far -> () 106: end 107: end 108: | _ -> () 109: ) 110: exes 111: 112: let create_label_usage syms bbdfns label_map = 113: let usage = Hashtbl.create 97 in 114: Hashtbl.iter 115: (fun index (id,parent,sr,entry) -> 116: match entry with 117: | `BBDCL_function (_,_,_,_,exes) 118: | `BBDCL_procedure (_,_,_,exes) -> 119: cal_usage syms bbdfns label_map index exes usage 120: | _ -> () 121: ) 122: bbdfns 123: ; 124: usage 125: