source: Deliverables/D2.2/8051/src/RTLabs/RTLabsPrinter.ml

Last change on this file was 1589, checked in by tranquil, 8 years ago
  • turned to argument-less return statements for RTLabs and RTL (there was a hidden invariant, for which the arguments of return statements where equal to the f_result field of the function definition: they were useless and an optimization was breaking the compilation)
  • corrected a bug in liveness analysis I had introduced
File size: 8.4 KB
Line 
1
2let n_spaces n = String.make n ' '
3
4
5let 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) ^ "]"
11and print_size_list l =
12  MiscPottier.string_of_list ", " print_size l
13
14let print_global n (x, size) =
15  Printf.sprintf "%s\"%s\" { %s }" (n_spaces n) x (print_size size)
16
17let 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
23let print_reg = Register.print
24
25let print_oreg = function
26  | None -> "_"
27  | Some r -> print_reg r
28
29let print_decl (r, t) =
30  (Primitive.print_type t) ^ " " ^ (Register.print r)
31
32let print_result = function
33  | None -> "_"
34  | Some (r, t) -> (Primitive.print_type t) ^ " " ^ (Register.print r)
35
36let print_params r =
37  Printf.sprintf "(%s)" (MiscPottier.string_of_list ", " print_decl r)
38
39let print_locals r =
40  Printf.sprintf "%s" (MiscPottier.string_of_list ", " print_decl r)
41
42
43let 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
51let 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) ^ "]"
57and print_size_list l =
58  MiscPottier.string_of_list ", " print_size l
59
60let print_stacksize = print_size
61
62let print_offset (size, depth) =
63  (print_size size) ^ ", " ^ (string_of_int depth)
64
65let print_sizeof = print_size
66
67let 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
75let 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
80let rec print_args args =
81  Printf.sprintf "[%s]" (MiscPottier.string_of_list ", " print_arg args)
82
83let string_of_signedness = function
84  | AST.Signed -> "s"
85  | AST.Unsigned -> "u"
86
87let string_of_int_type (size, sign) =
88  Printf.sprintf "%d%s" size (string_of_signedness sign)
89
90let 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
102let 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(*
128let 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
139let rec print_table = function
140  | [] -> ""
141  | [lbl] -> lbl
142  | lbl :: tbl -> lbl ^ ", " ^ (print_table tbl)
143
144
145let 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 -> Printf.sprintf "return"
248
249
250let print_graph n c entry =
251  let f lbl stmt s =
252    Printf.sprintf "%s%s: %s\n%s"
253      (n_spaces n)
254      lbl
255      (print_statement stmt)
256      s in
257  let f' lbl stmt (reach, s) =
258    (Label.Set.add lbl reach, f lbl stmt s) in
259  let module U = GraphUtilities.Util(RTLabsGraph) in
260  let (reachable, str) =
261    U.dfs_fold f' c entry (Label.Set.empty, "") in
262  let filter lbl _ = not (Label.Set.mem lbl reachable) in
263  let c_rest = Label.Map.filter filter c in
264  if Label.Map.is_empty c_rest then str else
265    let str' = Label.Map.fold f c_rest "" in
266    str ^ "DEAD NODES:\n" ^ str'
267       
268let print_internal_decl n f def =
269
270  Printf.sprintf
271    "%s\"%s\"%s\n%slocals: %s\n%sresult: %s\n%sstacksize: %s\n%sentry: %s\n%sexit: %s\n\n%s"
272    (n_spaces n)
273    f
274    (print_params def.RTLabs.f_params)
275    (n_spaces (n+2))
276    (print_locals def.RTLabs.f_locals)
277    (n_spaces (n+2))
278    (print_result def.RTLabs.f_result)
279    (n_spaces (n+2))
280    (print_stacksize def.RTLabs.f_stacksize)
281    (n_spaces (n+2))
282    def.RTLabs.f_entry
283    (n_spaces (n+2))
284    def.RTLabs.f_exit
285    (print_graph (n+2) def.RTLabs.f_graph def.RTLabs.f_entry)
286
287
288let print_external_decl n f def =
289  Printf.sprintf "%sextern \"%s\": %s\n"
290    (n_spaces n)
291    f
292    (Primitive.print_sig def.AST.ef_sig)
293
294
295let print_fun_decl n (f, def) = match def with
296  | RTLabs.F_int def -> print_internal_decl n f def
297  | RTLabs.F_ext def -> print_external_decl n f def
298
299let print_fun_decls n functs =
300  List.fold_left (fun s f -> s ^ (print_fun_decl n f) ^ "\n\n") ""
301    functs
302
303
304let print_program p =
305  Printf.sprintf "program:\n\n\n%s\n\n%s"
306    (print_globals 2 p.RTLabs.vars)
307    (print_fun_decls 2 p.RTLabs.functs)
Note: See TracBrowser for help on using the repository browser.