1 | |
---|
2 | let n_spaces n = String.make n ' ' |
---|
3 | |
---|
4 | |
---|
5 | let rec print_size = function |
---|
6 | | AST.SQ q -> Memory.string_of_quantity q |
---|
7 | | AST.SProd l -> "struct {" ^ (print_size_list l) ^ "}" |
---|
8 | | AST.SSum l -> "union {" ^ (print_size_list l) ^ "}" |
---|
9 | | AST.SArray (i, se) -> |
---|
10 | (print_size se) ^ "[" ^ (string_of_int i) ^ "]" |
---|
11 | and print_size_list l = |
---|
12 | MiscPottier.string_of_list ", " print_size l |
---|
13 | |
---|
14 | let print_global n (x, size) = |
---|
15 | Printf.sprintf "%s\"%s\" { %s }" (n_spaces n) x (print_size size) |
---|
16 | |
---|
17 | let print_globals n globs = |
---|
18 | Printf.sprintf "%sglobals:\n%s" |
---|
19 | (n_spaces n) |
---|
20 | (List.fold_left (fun s g -> s ^ (print_global (n+2) g) ^ "\n") "" globs) |
---|
21 | |
---|
22 | |
---|
23 | let print_reg = Register.print |
---|
24 | |
---|
25 | let print_oreg = function |
---|
26 | | None -> "_" |
---|
27 | | Some r -> print_reg r |
---|
28 | |
---|
29 | let print_decl (r, t) = |
---|
30 | (Primitive.print_type t) ^ " " ^ (Register.print r) |
---|
31 | |
---|
32 | let print_result = function |
---|
33 | | None -> "_" |
---|
34 | | Some (r, t) -> (Primitive.print_type t) ^ " " ^ (Register.print r) |
---|
35 | |
---|
36 | let print_params r = |
---|
37 | Printf.sprintf "(%s)" (MiscPottier.string_of_list ", " print_decl r) |
---|
38 | |
---|
39 | let print_locals r = |
---|
40 | Printf.sprintf "%s" (MiscPottier.string_of_list ", " print_decl r) |
---|
41 | |
---|
42 | |
---|
43 | let print_cmp = function |
---|
44 | | AST.Cmp_eq -> "=" |
---|
45 | | AST.Cmp_ne -> "!=" |
---|
46 | | AST.Cmp_gt -> ">" |
---|
47 | | AST.Cmp_ge -> ">=" |
---|
48 | | AST.Cmp_lt -> "<" |
---|
49 | | AST.Cmp_le -> "<=" |
---|
50 | |
---|
51 | let rec print_size = function |
---|
52 | | AST.SQ q -> Memory.string_of_quantity q |
---|
53 | | AST.SProd l -> "struct {" ^ (print_size_list l) ^ "}" |
---|
54 | | AST.SSum l -> "union {" ^ (print_size_list l) ^ "}" |
---|
55 | | AST.SArray (i, se) -> |
---|
56 | (print_size se) ^ "[" ^ (string_of_int i) ^ "]" |
---|
57 | and print_size_list l = |
---|
58 | MiscPottier.string_of_list ", " print_size l |
---|
59 | |
---|
60 | let print_stacksize = print_size |
---|
61 | |
---|
62 | let print_offset (size, depth) = |
---|
63 | (print_size size) ^ ", " ^ (string_of_int depth) |
---|
64 | |
---|
65 | let print_sizeof = print_size |
---|
66 | |
---|
67 | let print_cst = function |
---|
68 | | AST.Cst_int i -> Printf.sprintf "imm_int %d" i |
---|
69 | | AST.Cst_float f -> Printf.sprintf "imm_float %f" f |
---|
70 | | AST.Cst_addrsymbol id -> Printf.sprintf "imm_addr \"%s\"" id |
---|
71 | | AST.Cst_stack -> "imm_addr STACK" |
---|
72 | | AST.Cst_offset off -> Printf.sprintf "imm_offset { %s }" (print_offset off) |
---|
73 | | AST.Cst_sizeof t -> "imm_sizeof (" ^ (print_size t) ^ ")" |
---|
74 | |
---|
75 | let print_arg = function |
---|
76 | | RTLabs.Reg r -> print_reg r |
---|
77 | | RTLabs.Imm (c, t) -> |
---|
78 | Printf.sprintf "(%s)%s" (Primitive.print_type t) (print_cst c) |
---|
79 | |
---|
80 | let rec print_args args = |
---|
81 | Printf.sprintf "[%s]" (MiscPottier.string_of_list ", " print_arg args) |
---|
82 | |
---|
83 | let string_of_signedness = function |
---|
84 | | AST.Signed -> "s" |
---|
85 | | AST.Unsigned -> "u" |
---|
86 | |
---|
87 | let string_of_int_type (size, sign) = |
---|
88 | Printf.sprintf "%d%s" size (string_of_signedness sign) |
---|
89 | |
---|
90 | let print_op1 op r = Printf.sprintf "%s %s" |
---|
91 | (match op with |
---|
92 | | AST.Op_cast (int_type, dest_size) -> |
---|
93 | Printf.sprintf "int%sto%d" (string_of_int_type int_type) dest_size |
---|
94 | | AST.Op_negint -> "-" |
---|
95 | | AST.Op_notbool -> "!" |
---|
96 | | AST.Op_notint -> "!i" |
---|
97 | | AST.Op_id -> "" |
---|
98 | | AST.Op_ptrofint -> "ptrofint" |
---|
99 | | AST.Op_intofptr -> "intofptr") |
---|
100 | (print_reg r) |
---|
101 | |
---|
102 | let print_op2 op r s = Printf.sprintf "%s %s %s" |
---|
103 | (print_arg r) |
---|
104 | (match op with |
---|
105 | | AST.Op_add -> "+" |
---|
106 | | AST.Op_sub -> "-" |
---|
107 | | AST.Op_mul -> "*" |
---|
108 | | AST.Op_div -> "/" |
---|
109 | | AST.Op_divu -> "/u" |
---|
110 | | AST.Op_mod -> "mod" |
---|
111 | | AST.Op_modu -> "modu" |
---|
112 | | AST.Op_and -> "and" |
---|
113 | | AST.Op_or -> "or" |
---|
114 | | AST.Op_xor -> "xor" |
---|
115 | | AST.Op_shl -> "<<" |
---|
116 | | AST.Op_shr -> ">>" |
---|
117 | | AST.Op_shru -> ">>u" |
---|
118 | | AST.Op_cmp cmp -> print_cmp cmp |
---|
119 | | AST.Op_addp -> "+p" |
---|
120 | | AST.Op_subp -> "-p" |
---|
121 | | AST.Op_subpp -> "-pp" |
---|
122 | | AST.Op_cmpp cmp -> (print_cmp cmp) ^ "p" |
---|
123 | | AST.Op_cmpu cmp -> (print_cmp cmp) ^ "u") |
---|
124 | (print_arg s) |
---|
125 | |
---|
126 | |
---|
127 | (* |
---|
128 | let print_addressing = function |
---|
129 | | RTLabs.Aindexed off -> Printf.sprintf "{ %s }" (print_offset off) |
---|
130 | | RTLabs.Aindexed2 -> "add" |
---|
131 | | RTLabs.Aglobal (id, off) -> |
---|
132 | Printf.sprintf "{ %s }(\"%s\")" (print_offset off) id |
---|
133 | | RTLabs.Abased (id, off) -> |
---|
134 | Printf.sprintf "add, { %s }(\"%s\")" (print_offset off) id |
---|
135 | | RTLabs.Ainstack off -> Printf.sprintf "{ %s }(STACK)" (print_offset off) |
---|
136 | *) |
---|
137 | |
---|
138 | |
---|
139 | let rec print_table = function |
---|
140 | | [] -> "" |
---|
141 | | [lbl] -> lbl |
---|
142 | | lbl :: tbl -> lbl ^ ", " ^ (print_table tbl) |
---|
143 | |
---|
144 | |
---|
145 | let print_statement = function |
---|
146 | | RTLabs.St_skip lbl -> "--> " ^ lbl |
---|
147 | | RTLabs.St_cost (cost_lbl, lbl) -> |
---|
148 | let cost_lbl = CostLabel.string_of_cost_label ~pretty:true cost_lbl in |
---|
149 | Printf.sprintf "emit %s --> %s" cost_lbl lbl |
---|
150 | | RTLabs.St_ind_0 (i, lbl) -> |
---|
151 | Printf.sprintf "index %d --> %s" i lbl |
---|
152 | | RTLabs.St_ind_inc (i, lbl) -> |
---|
153 | Printf.sprintf "increment %d --> %s" i lbl |
---|
154 | | RTLabs.St_cst (destr, cst, lbl) -> |
---|
155 | Printf.sprintf "%s := %s --> %s" |
---|
156 | (print_reg destr) |
---|
157 | (print_cst cst) |
---|
158 | lbl |
---|
159 | | RTLabs.St_op1 (op1, destr, srcr, lbl) -> |
---|
160 | Printf.sprintf "%s := %s --> %s" |
---|
161 | (print_reg destr) |
---|
162 | (print_op1 op1 srcr) |
---|
163 | lbl |
---|
164 | | RTLabs.St_op2 (op2, destr, srcr1, srcr2, lbl) -> |
---|
165 | Printf.sprintf "%s := %s --> %s" |
---|
166 | (print_reg destr) |
---|
167 | (print_op2 op2 srcr1 srcr2) |
---|
168 | lbl |
---|
169 | | RTLabs.St_load (q, addr, destr, lbl) -> |
---|
170 | Printf.sprintf "%s := (%s) *%s --> %s" |
---|
171 | (print_reg destr) |
---|
172 | (Memory.string_of_quantity q) |
---|
173 | (print_arg addr) |
---|
174 | lbl |
---|
175 | | RTLabs.St_store (q, addr, srcr, lbl) -> |
---|
176 | Printf.sprintf "*%s := (%s)%s --> %s" |
---|
177 | (print_arg addr) |
---|
178 | (Memory.string_of_quantity q) |
---|
179 | (print_arg srcr) |
---|
180 | lbl |
---|
181 | | RTLabs.St_call_id (f, args, Some r, sg, lbl) -> |
---|
182 | Printf.sprintf "%s := \"%s\"(%s) : %s --> %s" |
---|
183 | (print_reg r) |
---|
184 | f |
---|
185 | (print_args args) |
---|
186 | (Primitive.print_sig sg) |
---|
187 | lbl |
---|
188 | | RTLabs.St_call_id (f, args, None, sg, lbl) -> |
---|
189 | Printf.sprintf "\"%s\"(%s) : %s --> %s" |
---|
190 | f |
---|
191 | (print_args args) |
---|
192 | (Primitive.print_sig sg) |
---|
193 | lbl |
---|
194 | | RTLabs.St_call_ptr (f, args, Some r, sg, lbl) -> |
---|
195 | Printf.sprintf "%s := *%s (%s) : %s --> %s" |
---|
196 | (print_reg r) |
---|
197 | (print_reg f) |
---|
198 | (print_args args) |
---|
199 | (Primitive.print_sig sg) |
---|
200 | lbl |
---|
201 | | RTLabs.St_call_ptr (f, args, None, sg, lbl) -> |
---|
202 | Printf.sprintf "*%s (%s) : %s --> %s" |
---|
203 | (print_reg f) |
---|
204 | (print_args args) |
---|
205 | (Primitive.print_sig sg) |
---|
206 | lbl |
---|
207 | | RTLabs.St_tailcall_id (f, args, sg) -> |
---|
208 | Printf.sprintf "tailcall \"%s\" (%s) : %s" |
---|
209 | f |
---|
210 | (print_args args) |
---|
211 | (Primitive.print_sig sg) |
---|
212 | | RTLabs.St_tailcall_ptr (f, args, sg) -> |
---|
213 | Printf.sprintf "tailcall *%s (%s) : %s" |
---|
214 | (print_reg f) |
---|
215 | (print_args args) |
---|
216 | (Primitive.print_sig sg) |
---|
217 | | RTLabs.St_cond (r, lbl_true, lbl_false) -> |
---|
218 | Printf.sprintf "if %s --> %s else --> %s" |
---|
219 | (print_reg r) |
---|
220 | lbl_true |
---|
221 | lbl_false |
---|
222 | (* |
---|
223 | | RTLabs.St_condcst (cst, t, lbl_true, lbl_false) -> |
---|
224 | Printf.sprintf "(%s) %s --> %s, %s" |
---|
225 | (Primitive.print_type t) |
---|
226 | (print_cst cst) |
---|
227 | lbl_true |
---|
228 | lbl_false |
---|
229 | | RTLabs.St_cond1 (op1, srcr, lbl_true, lbl_false) -> |
---|
230 | Printf.sprintf "%s %s --> %s, %s" |
---|
231 | (print_op1 op1) |
---|
232 | (print_reg srcr) |
---|
233 | lbl_true |
---|
234 | lbl_false |
---|
235 | | RTLabs.St_cond2 (op2, srcr1, srcr2, lbl_true, lbl_false) -> |
---|
236 | Printf.sprintf "%s %s, %s --> %s, %s" |
---|
237 | (print_op2 op2) |
---|
238 | (print_reg srcr1) |
---|
239 | (print_reg srcr2) |
---|
240 | lbl_true |
---|
241 | lbl_false |
---|
242 | *) |
---|
243 | | RTLabs.St_jumptable (r, tbl) -> |
---|
244 | Printf.sprintf "j_tbl %s --> %s" |
---|
245 | (print_reg r) |
---|
246 | (print_table tbl) |
---|
247 | | RTLabs.St_return None -> Printf.sprintf "return" |
---|
248 | | RTLabs.St_return (Some r) -> Printf.sprintf "return %s" (print_arg r) |
---|
249 | |
---|
250 | |
---|
251 | let print_graph n c entry = |
---|
252 | let f lbl stmt s = |
---|
253 | Printf.sprintf "%s%s: %s\n%s" |
---|
254 | (n_spaces n) |
---|
255 | lbl |
---|
256 | (print_statement stmt) |
---|
257 | s in |
---|
258 | let f' lbl stmt (reach, s) = |
---|
259 | (Label.Set.add lbl reach, f lbl stmt s) in |
---|
260 | let module U = GraphUtilities.Util(RTLabsGraph) in |
---|
261 | let (reachable, str) = |
---|
262 | U.dfs_fold f' c entry (Label.Set.empty, "") in |
---|
263 | let filter lbl _ = not (Label.Set.mem lbl reachable) in |
---|
264 | let c_rest = Label.Map.filter filter c in |
---|
265 | if Label.Map.is_empty c_rest then str else |
---|
266 | let str' = Label.Map.fold f c_rest "" in |
---|
267 | str ^ "DEAD NODES:\n" ^ str' |
---|
268 | |
---|
269 | let print_internal_decl n f def = |
---|
270 | |
---|
271 | Printf.sprintf |
---|
272 | "%s\"%s\"%s\n%slocals: %s\n%sresult: %s\n%sstacksize: %s\n%sentry: %s\n%sexit: %s\n\n%s" |
---|
273 | (n_spaces n) |
---|
274 | f |
---|
275 | (print_params def.RTLabs.f_params) |
---|
276 | (n_spaces (n+2)) |
---|
277 | (print_locals def.RTLabs.f_locals) |
---|
278 | (n_spaces (n+2)) |
---|
279 | (print_result def.RTLabs.f_result) |
---|
280 | (n_spaces (n+2)) |
---|
281 | (print_stacksize def.RTLabs.f_stacksize) |
---|
282 | (n_spaces (n+2)) |
---|
283 | def.RTLabs.f_entry |
---|
284 | (n_spaces (n+2)) |
---|
285 | def.RTLabs.f_exit |
---|
286 | (print_graph (n+2) def.RTLabs.f_graph def.RTLabs.f_entry) |
---|
287 | |
---|
288 | |
---|
289 | let print_external_decl n f def = |
---|
290 | Printf.sprintf "%sextern \"%s\": %s\n" |
---|
291 | (n_spaces n) |
---|
292 | f |
---|
293 | (Primitive.print_sig def.AST.ef_sig) |
---|
294 | |
---|
295 | |
---|
296 | let print_fun_decl n (f, def) = match def with |
---|
297 | | RTLabs.F_int def -> print_internal_decl n f def |
---|
298 | | RTLabs.F_ext def -> print_external_decl n f def |
---|
299 | |
---|
300 | let print_fun_decls n functs = |
---|
301 | List.fold_left (fun s f -> s ^ (print_fun_decl n f) ^ "\n\n") "" |
---|
302 | functs |
---|
303 | |
---|
304 | |
---|
305 | let print_program p = |
---|
306 | Printf.sprintf "program:\n\n\n%s\n\n%s" |
---|
307 | (print_globals 2 p.RTLabs.vars) |
---|
308 | (print_fun_decls 2 p.RTLabs.functs) |
---|