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