source: Deliverables/D2.2/8051-indexed-labels-branch/src/RTLabs/RTLabsPrinter.ml @ 1340

Last change on this file since 1340 was 1340, checked in by tranquil, 8 years ago

work on RTLabs and RTL completed

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