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) -> Hashtbl.add labels s !counter; incr counter 29: | _ -> () 30: ) 31: exes 32: ; 33: labels 34: 35: let create_label_map bbdfns counter = 36: let label_map = Hashtbl.create 97 in 37: Hashtbl.iter 38: (fun index (id,parent,sr,entry) -> 39: match entry with 40: | `BBDCL_function (_,_,_,_,exes) -> 41: Hashtbl.add label_map index (get_labels bbdfns counter exes) 42: | `BBDCL_procedure (_,_,_,exes) -> 43: Hashtbl.add label_map index (get_labels bbdfns counter exes) 44: | _ -> () 45: ) 46: bbdfns 47: ; 48: label_map 49: 50: 51: let rec find_label bbdfns label_map caller label = 52: let labels = Hashtbl.find label_map caller in 53: try `Local (Hashtbl.find labels label) 54: with Not_found -> 55: let id,parent,sr,entry = Hashtbl.find bbdfns caller in 56: match entry with 57: | `BBDCL_function _ -> `Unreachable 58: | `BBDCL_procedure _ -> 59: begin match parent with None -> `Unreachable 60: | Some parent -> 61: begin match find_label bbdfns label_map parent label with 62: | `Local i -> `Nonlocal (i,parent) 63: | x -> x 64: end 65: end 66: | _ -> assert false 67: 68: let get_label_kind_from_index usage lix = 69: try Hashtbl.find usage lix with Not_found -> `Unused 70: 71: let get_label_kind label_map usage_map proc label = 72: let labels = Hashtbl.find label_map proc in 73: let lix = Hashtbl.find labels label in 74: get_label_kind_from_index usage_map lix 75: 76: 77: let cal_usage syms bbdfns label_map caller exes usage = 78: iter 79: (function 80: | `BEXE_goto (sr,label) 81: | `BEXE_ifgoto (sr,_,label) 82: | `BEXE_ifnotgoto (sr,_,label) -> 83: begin match find_label bbdfns label_map caller label with 84: | `Unreachable -> 85: syserr sr ("Jump to unreachable label " ^ label ^ "\n" ^ 86: (catmap "\n" (string_of_bexe syms.dfns 2) exes)) 87: | `Local lix -> 88: begin match get_label_kind_from_index usage lix with 89: | `Unused -> Hashtbl.replace usage lix `Near 90: | `Near | `Far -> () 91: end 92: | `Nonlocal (lix,_) -> 93: begin match get_label_kind_from_index usage lix with 94: | `Unused | `Near -> Hashtbl.replace usage lix `Far 95: | `Far -> () 96: end 97: end 98: | _ -> () 99: ) 100: exes 101: 102: let create_label_usage syms bbdfns label_map = 103: let usage = Hashtbl.create 97 in 104: Hashtbl.iter 105: (fun index (id,parent,sr,entry) -> 106: match entry with 107: | `BBDCL_function (_,_,_,_,exes) 108: | `BBDCL_procedure (_,_,_,exes) -> 109: cal_usage syms bbdfns label_map index exes usage 110: | _ -> () 111: ) 112: bbdfns 113: ; 114: usage 115: