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: