5.42. label management

Start ocaml section to src/flx_label.mli[1 /1 ]
     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: 
End ocaml section to src/flx_label.mli[1]
Start ocaml section to src/flx_label.ml[1 /1 ]
     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: 
End ocaml section to src/flx_label.ml[1]