5.43. Control Flow

Start ocaml section to src/flx_cflow.mli[1 /1 ]
     1: # 3 "./lpsrc/flx_cflow.ipk"
     2: open Flx_types
     3: open Flx_mtypes2
     4: 
     5: val tailable:
     6:   bexe_t list ->
     7:   string list ->
     8:   bexe_t list ->
     9:   bool
    10: 
    11: val chain_gotos:
    12:   sym_state_t ->
    13:   bexe_t list -> bexe_t list
    14: 
    15: val final_tailcall_opt:
    16:   bexe_t list -> bexe_t list
    17: 
End ocaml section to src/flx_cflow.mli[1]
Start ocaml section to src/flx_cflow.ml[1 /1 ]
     1: # 20 "./lpsrc/flx_cflow.ipk"
     2: open Flx_types
     3: open List
     4: open Flx_util
     5: open Flx_mtypes2
     6: open Flx_print
     7: 
     8: let rec find_label tail label =
     9:   match tail with
    10:   | [] -> None
    11:   | `BEXE_label (_,x) :: tail when x = label -> Some tail
    12:   | _ :: tail -> find_label tail label
    13: 
    14: (* tell whether there is any reachable executable code here:
    15:   if not, a previous call is a tail call
    16: *)
    17: let rec tailable exes exclude tail =
    18:   let rec aux tail = match tail with
    19:   | [] -> true
    20:   | h :: t -> match h with
    21:     | `BEXE_proc_return _ -> true
    22:     | `BEXE_comment _
    23:     | `BEXE_label _
    24:     | `BEXE_nop _
    25:       -> aux t
    26:     | `BEXE_goto (_,label) ->
    27:       if mem label exclude then false (* infinite loop *)
    28:       else
    29:         begin match find_label exes label with
    30:         | None -> false
    31:         | Some tail -> tailable exes (label::exclude) tail
    32:         end
    33:     | `BEXE_ifgoto (_,_,label)
    34:     | `BEXE_ifnotgoto (_,_,label) ->
    35:       if mem label exclude then false (* infinite loop *)
    36:       else
    37:         begin match find_label exes label with
    38:         | None -> false
    39:         | Some tail ->
    40:           if tailable exes (label::exclude) tail then
    41:             tailable exes exclude t
    42:           else false
    43:         end
    44:     | _ -> false
    45:   in aux tail
    46: 
    47: let rec skip_white tail : bexe_t list =
    48:   match tail with
    49:   | [] -> []
    50:   | h :: t ->
    51:     match h with
    52:     | `BEXE_comment _
    53:     | `BEXE_nop _  -> skip_white t
    54:     | _ -> tail
    55: 
    56: let rec can_drop s tail : bool =
    57:   match tail with
    58:   | [] -> false
    59:   | h :: t ->
    60:     match h with
    61:     | `BEXE_comment _
    62:     | `BEXE_nop _  -> can_drop s t
    63:     | `BEXE_label (_,s') ->
    64:       if s <> s' then can_drop s t
    65:       else true
    66: 
    67:     | _ -> false
    68: 
    69: let rec retarget exes exe exclude : bexe_t =
    70:   match exe with
    71:   | `BEXE_goto (sr,label) ->
    72:     (*
    73:     print_endline ("Checking label " ^ label);
    74:     *)
    75:     begin match find_label exes label with
    76:     | None -> exe
    77:     | Some tail ->
    78:       match skip_white tail with
    79:       | [] ->
    80:          (*
    81:          print_endline ("[goto] Retargetting " ^ label ^ " to tail");
    82:          *)
    83:         `BEXE_proc_return sr
    84:       | h :: t ->
    85:         match h with
    86:         | `BEXE_proc_return _ ->
    87:           (*
    88:           print_endline ("[goto] Retargetting " ^ label ^ " to return");
    89:           *)
    90:           h
    91:         | `BEXE_goto (_,s) ->
    92:           (*
    93:           print_endline ("[goto] Retargetting " ^ label ^ " to " ^ s);
    94:           *)
    95:           if mem s exclude then `BEXE_halt (sr,"infinite loop")
    96:           else retarget exes h (s::exclude)
    97:         | `BEXE_label (_,s) ->
    98:           (*
    99:           print_endline ("[goto] Retargetting " ^ label ^ " to " ^ s);
   100:           *)
   101:           retarget exes (`BEXE_goto (sr,s)) exclude
   102: 
   103:         | _ -> exe
   104:     end
   105: 
   106:   | `BEXE_ifgoto (sr,e,label) ->
   107:     (*
   108:     print_endline ("Checking label " ^ label);
   109:     *)
   110:     begin match find_label exes label with
   111:     | None -> exe
   112:     | Some tail ->
   113:       match skip_white tail with
   114:       | [] -> exe
   115:       | h :: t ->
   116:         match h with
   117:         | `BEXE_goto (_,s) ->
   118:           (*
   119:           print_endline ("[ifgoto] Retargetting " ^ label ^ " to " ^ s);
   120:           *)
   121:           if mem s exclude then `BEXE_halt (sr,"infinite loop")
   122:           else retarget exes (`BEXE_ifgoto (sr,e,s)) (s::exclude)
   123:         | `BEXE_label (_,s) ->
   124:           (*
   125:           print_endline ("[ifgoto] Retargetting " ^ label ^ " to " ^ s);
   126:           *)
   127:           retarget exes (`BEXE_ifgoto (sr,e,s)) (s::exclude)
   128:         | _ -> exe
   129:     end
   130: 
   131:   | `BEXE_ifnotgoto (sr,e,label) ->
   132:     (*
   133:     print_endline ("Checking label " ^ label);
   134:     *)
   135:     begin match find_label exes label with
   136:     | None -> exe
   137:     | Some tail ->
   138:       match skip_white tail with
   139:       | [] -> exe
   140:       | h :: t ->
   141:         match h with
   142:         | `BEXE_goto (_,s) ->
   143:           (*
   144:           print_endline ("[ifnotgoto] Retargetting " ^ label ^ " to " ^ s);
   145:           *)
   146:           if mem s exclude then `BEXE_halt (sr,"infinite loop")
   147:           else retarget exes (`BEXE_ifnotgoto (sr,e,s)) (s::exclude)
   148:         | `BEXE_label (_,s) ->
   149:           (*
   150:           print_endline ("[ifnotgoto] Retargetting " ^ label ^ " to " ^ s);
   151:           *)
   152:           retarget exes (`BEXE_ifnotgoto (sr,e,s)) (s::exclude)
   153:         | _ -> exe
   154:     end
   155:   | _ -> exe
   156: 
   157: let chain_gotos' exes =
   158:   let rec aux tail out =
   159:     match tail with
   160:     | [] -> rev out
   161:     | h :: t ->
   162:       let h = retarget exes h [] in
   163:       aux t (h :: out)
   164:   in aux exes []
   165: 
   166: let fix_dropthrus syms exes =
   167:   let rec aux tail out =
   168:     match tail with
   169:     | [] -> rev out
   170:     |
   171:     ( `BEXE_goto (_,s)
   172:     | `BEXE_ifgoto (_,_,s)
   173:     | `BEXE_ifnotgoto (_,_,s)
   174:     ) as h :: t ->
   175:       if can_drop s t
   176:       then aux t out
   177:       else aux t (h::out)
   178:     | h::t -> aux t (h::out)
   179:   in aux exes []
   180: 
   181: let chain_gotos syms exes =
   182:   let exes = chain_gotos' exes in
   183:   fix_dropthrus syms exes
   184: 
   185: (* this procedure converts tail calls into jumps, it is ONLY
   186: intended to be used temporarily whilst the inlining code
   187: can't handle jump instruction
   188: *)
   189: 
   190: let final_tailcall_opt exes =
   191:   let rec aux inp out = match inp with
   192:     | [] -> rev out
   193:     | `BEXE_call_direct (sr,i,ts,a) :: tail
   194:       when tailable exes [] tail
   195:       -> aux tail (`BEXE_jump_direct (sr,i,ts,a) :: out)
   196:     | `BEXE_call (sr,a,b) :: tail
   197:       when tailable exes [] tail
   198:       -> aux tail (`BEXE_jump (sr,a,b) :: out)
   199:     | head :: tail -> aux tail (head :: out)
   200:   in aux exes []
   201: 
End ocaml section to src/flx_cflow.ml[1]