]> matita.cs.unibo.it Git - pkg-cerco/acc.git/blob - src/RTLabs/RTLabsPrinter.ml
Package description and copyright added.
[pkg-cerco/acc.git] / src / RTLabs / RTLabsPrinter.ml
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_size = print_size
15
16 let print_data = function
17 (*
18   | Data_reserve n -> Printf.sprintf "[%d]" n
19 *)
20   | AST.Data_int8 i -> Printf.sprintf "(int8) %d" i
21   | AST.Data_int16 i -> Printf.sprintf "(int16) %d" i
22   | AST.Data_int32 i -> Printf.sprintf "%d" i
23   | AST.Data_float32 f -> Printf.sprintf "%f" f
24   | AST.Data_float64 f -> Printf.sprintf "(float64) %f" f
25
26 let print_datas init =
27   let rec aux = function
28     | [] -> ""
29     | [data] -> print_data data
30     | data :: datas -> Printf.sprintf "%s, %s" (print_data data) (aux datas)
31   in
32   Printf.sprintf "{%s}" (aux init)
33
34 let print_datas_opt = function
35   | None -> ""
36   | Some init -> " = " ^ (print_datas init)
37
38 let print_global n (id, size, init_opt) =
39   Printf.sprintf "%s\"%s\" : %s%s;\n"
40     (n_spaces n) id (print_global_size size) (print_datas_opt init_opt)
41
42 let print_globals eformat n =
43   List.iter (fun v -> Eformat.printf eformat "%s" (print_global n v))
44
45
46 let print_reg = Register.print
47
48 let print_oreg = function
49   | None -> "_"
50   | Some r -> print_reg r
51
52 let print_decl (r, t) =
53   (Primitive.print_type t) ^ " " ^ (Register.print r)
54
55 let rec print_args args =
56   Printf.sprintf "[%s]" (MiscPottier.string_of_list ", " print_reg args)
57
58 let print_result = function
59   | None -> "_"
60   | Some (r, t) -> (Primitive.print_type t) ^ " " ^ (Register.print r)
61
62 let print_params r =
63   Printf.sprintf "(%s)" (MiscPottier.string_of_list ", " print_decl r)
64
65 let print_locals r =
66   Printf.sprintf "%s" (MiscPottier.string_of_list ", " print_decl r)
67
68
69 let print_cmp = function
70   | AST.Cmp_eq -> "eq"
71   | AST.Cmp_ne -> "ne"
72   | AST.Cmp_gt -> "gt"
73   | AST.Cmp_ge -> "ge"
74   | AST.Cmp_lt -> "lt"
75   | AST.Cmp_le -> "le"
76
77 let rec print_size = function
78   | AST.SQ q -> Memory.string_of_quantity q
79   | AST.SProd l -> "struct {" ^ (print_size_list l) ^ "}"
80   | AST.SSum l -> "union {" ^ (print_size_list l) ^ "}"
81   | AST.SArray (i, se) ->
82     (print_size se) ^ "[" ^ (string_of_int i) ^ "]"
83 and print_size_list l =
84   MiscPottier.string_of_list ", " print_size l
85
86 let print_stacksize = print_size
87
88 let print_offset (size, depth) =
89   (print_size size) ^ ", " ^ (string_of_int depth)
90
91 let print_sizeof = print_size
92
93 let print_cst = function
94   | AST.Cst_int i -> Printf.sprintf "imm_int %d" i
95   | AST.Cst_float f -> Printf.sprintf "imm_float %f" f
96   | AST.Cst_addrsymbol id -> Printf.sprintf "imm_addr \"%s\"" id
97   | AST.Cst_stack -> "imm_addr STACK"
98   | AST.Cst_offset off -> Printf.sprintf "imm_offset { %s }" (print_offset off)
99   | AST.Cst_sizeof t -> "imm_sizeof (" ^ (print_size t) ^ ")"
100
101 let string_of_signedness = function
102   | AST.Signed -> "s"
103   | AST.Unsigned -> "u"
104
105 let string_of_int_type (size, sign) =
106   Printf.sprintf "%d%s" size (string_of_signedness sign)
107
108 let print_op1 = function
109   | AST.Op_cast (int_type, dest_size) ->
110     Printf.sprintf "int%sto%d" (string_of_int_type int_type) dest_size
111   | AST.Op_negint -> "negint"
112   | AST.Op_notbool -> "notbool"
113   | AST.Op_notint -> "notint"
114   | AST.Op_id -> "id"
115   | AST.Op_ptrofint -> "ptrofint"
116   | AST.Op_intofptr -> "intofptr"
117
118 let print_op2 = function
119   | AST.Op_add -> "add"
120   | AST.Op_sub -> "sub"
121   | AST.Op_mul -> "mul"
122   | AST.Op_div -> "div"
123   | AST.Op_divu -> "/u"
124   | AST.Op_mod -> "mod"
125   | AST.Op_modu -> "modu"
126   | AST.Op_and -> "and"
127   | AST.Op_or -> "or"
128   | AST.Op_xor -> "xor"
129   | AST.Op_shl -> "shl"
130   | AST.Op_shr -> "shr"
131   | AST.Op_shru -> "shru"
132   | AST.Op_cmp cmp -> print_cmp cmp
133   | AST.Op_addp -> "addp"
134   | AST.Op_subp -> "subp"
135   | AST.Op_subpp -> "subpp"
136   | AST.Op_cmpp cmp -> (print_cmp cmp) ^ "p"
137   | AST.Op_cmpu cmp -> (print_cmp cmp) ^ "u"
138
139
140 (*
141 let print_addressing = function
142   | RTLabs.Aindexed off -> Printf.sprintf "{ %s }" (print_offset off)
143   | RTLabs.Aindexed2 -> "add"
144   | RTLabs.Aglobal (id, off) ->
145     Printf.sprintf "{ %s }(\"%s\")" (print_offset off) id
146   | RTLabs.Abased (id, off) ->
147     Printf.sprintf "add, { %s }(\"%s\")" (print_offset off) id
148   | RTLabs.Ainstack off -> Printf.sprintf "{ %s }(STACK)" (print_offset off)
149 *)
150
151
152 let rec print_table = function
153   | [] -> ""
154   | [lbl] -> lbl
155   | lbl :: tbl -> lbl ^ ", " ^ (print_table tbl)
156
157
158 let print_statement = function
159   | RTLabs.St_skip lbl -> "--> " ^ lbl
160   | RTLabs.St_cost (cost_lbl, lbl) ->
161       Printf.sprintf "emit %s --> %s" cost_lbl lbl
162   | RTLabs.St_cst (destr, cst, lbl) ->
163       Printf.sprintf "imm %s, %s --> %s"
164         (print_reg destr)
165         (print_cst cst)
166         lbl
167   | RTLabs.St_op1 (op1, destr, srcr, lbl) ->
168       Printf.sprintf "%s %s, %s --> %s"
169         (print_op1 op1)
170         (print_reg destr)
171         (print_reg srcr)
172         lbl
173   | RTLabs.St_op2 (op2, destr, srcr1, srcr2, lbl) ->
174       Printf.sprintf "%s %s, %s, %s --> %s"
175         (print_op2 op2)
176         (print_reg destr)
177         (print_reg srcr1)
178         (print_reg srcr2)
179         lbl
180   | RTLabs.St_load (q, addr, destr, lbl) ->
181       Printf.sprintf "load %s, %s, %s --> %s"
182         (Memory.string_of_quantity q)
183         (print_reg addr)
184         (print_reg destr)
185         lbl
186   | RTLabs.St_store (q, addr, srcr, lbl) ->
187       Printf.sprintf "store %s, %s, %s --> %s"
188         (Memory.string_of_quantity q)
189         (print_reg addr)
190         (print_reg srcr)
191         lbl
192   | RTLabs.St_call_id (f, args, res, sg, lbl) ->
193       Printf.sprintf "call \"%s\", %s, %s: %s --> %s"
194         f
195         (print_args args)
196         (print_oreg res)
197         (Primitive.print_sig sg)
198         lbl
199   | RTLabs.St_call_ptr (f, args, res, sg, lbl) ->
200       Printf.sprintf "call_ptr %s, %s, %s: %s --> %s"
201         (print_reg f)
202         (print_args args)
203         (print_oreg res)
204         (Primitive.print_sig sg)
205         lbl
206   | RTLabs.St_tailcall_id (f, args, sg) ->
207       Printf.sprintf "tailcall \"%s\", %s: %s"
208         f
209         (print_args args)
210         (Primitive.print_sig sg)
211   | RTLabs.St_tailcall_ptr (f, args, sg) ->
212       Printf.sprintf "tailcall_ptr \"%s\", %s: %s"
213         (print_reg f)
214         (print_args args)
215         (Primitive.print_sig sg)
216   | RTLabs.St_cond (r, lbl_true, lbl_false) ->
217       Printf.sprintf "%s? --> %s, %s"
218         (print_reg r)
219         lbl_true
220         lbl_false
221 (*
222   | RTLabs.St_condcst (cst, t, lbl_true, lbl_false) ->
223       Printf.sprintf "(%s) %s --> %s, %s"
224         (Primitive.print_type t)
225         (print_cst cst)
226         lbl_true
227         lbl_false
228   | RTLabs.St_cond1 (op1, srcr, lbl_true, lbl_false) ->
229       Printf.sprintf "%s %s --> %s, %s"
230         (print_op1 op1)
231         (print_reg srcr)
232         lbl_true
233         lbl_false
234   | RTLabs.St_cond2 (op2, srcr1, srcr2, lbl_true, lbl_false) ->
235       Printf.sprintf "%s %s, %s --> %s, %s"
236         (print_op2 op2)
237         (print_reg srcr1)
238         (print_reg srcr2)
239         lbl_true
240         lbl_false
241 *)
242   | RTLabs.St_jumptable (r, tbl) ->
243       Printf.sprintf "j_tbl %s --> %s"
244         (print_reg r)
245         (print_table tbl)
246   | RTLabs.St_return None -> Printf.sprintf "return"
247   | RTLabs.St_return (Some r) -> Printf.sprintf "return %s" (print_reg r)
248
249
250 let print_graph eformat n c =
251   let f lbl stmt =
252     Eformat.printf eformat "%s%s: %s\n"
253       (n_spaces n)
254       lbl
255       (print_statement stmt) in
256   Label.Map.iter f c
257
258
259 let print_internal_decl eformat n f def =
260   Eformat.printf eformat
261     "%s\"%s\"%s\n%slocals: %s\n%sresult: %s\n%sstacksize: %s\n%sentry: %s\n%sexit: %s\n\n"
262     (n_spaces n)
263     f
264     (print_params def.RTLabs.f_params)
265     (n_spaces (n+2))
266     (print_locals def.RTLabs.f_locals)
267     (n_spaces (n+2))
268     (print_result def.RTLabs.f_result)
269     (n_spaces (n+2))
270     (print_stacksize def.RTLabs.f_stacksize)
271     (n_spaces (n+2))
272     def.RTLabs.f_entry
273     (n_spaces (n+2))
274     def.RTLabs.f_exit ;
275   print_graph eformat (n+2) def.RTLabs.f_graph
276
277
278 let print_external_decl eformat n f def =
279   Eformat.printf eformat "%sextern \"%s\": %s\n"
280     (n_spaces n)
281     f
282     (Primitive.print_sig def.AST.ef_sig)
283
284
285 let print_fun_decl eformat n (f, def) = match def with
286   | RTLabs.F_int def -> print_internal_decl eformat n f def
287   | RTLabs.F_ext def -> print_external_decl eformat n f def
288
289 let print_fun_decls eformat n functs =
290   List.iter
291     (fun f -> print_fun_decl eformat n f ; Eformat.printf eformat "\n\n")
292     functs
293
294
295 let print_program p =
296   let eformat = Eformat.create () in
297   Eformat.printf eformat "program:\n\n\n" ;
298   print_globals eformat 2 p.RTLabs.vars ;
299   Eformat.printf eformat "\n\n" ;
300   print_fun_decls eformat 2 p.RTLabs.functs ;
301   Eformat.get eformat