1 | |
---|
2 | (** This module provides a function to print [ERTL] programs. *) |
---|
3 | |
---|
4 | |
---|
5 | let n_spaces n = String.make n ' ' |
---|
6 | |
---|
7 | |
---|
8 | let print_global n (x, size) = |
---|
9 | Printf.sprintf "%s\"%s\" [%d]" (n_spaces n) x size |
---|
10 | |
---|
11 | let print_globals n globs = |
---|
12 | Printf.sprintf "%sglobals:\n%s" |
---|
13 | (n_spaces n) |
---|
14 | (List.fold_left (fun s g -> s ^ (print_global (n+2) g) ^ "\n") "" globs) |
---|
15 | |
---|
16 | |
---|
17 | let reg_set_to_list rs = |
---|
18 | let f r l = l @ [r] in |
---|
19 | Register.Set.fold f rs [] |
---|
20 | |
---|
21 | let print_reg_list first last sep f rl = |
---|
22 | Printf.sprintf "%s%s%s" |
---|
23 | first (MiscPottier.string_of_list sep f rl) last |
---|
24 | |
---|
25 | let print_ptr rl = print_reg_list "[" "]" " ; " Register.print rl |
---|
26 | |
---|
27 | let print_args rl = print_reg_list "(" ")" ", " Register.print rl |
---|
28 | |
---|
29 | let print_return rl = print_reg_list "[" "]" " ; " Register.print rl |
---|
30 | |
---|
31 | let print_params rl = print_reg_list "(" ")" ", " Register.print rl |
---|
32 | |
---|
33 | let print_locals rs = |
---|
34 | let rl = reg_set_to_list rs in |
---|
35 | Printf.sprintf "%s" (print_reg_list "" "" ", " Register.print rl) |
---|
36 | |
---|
37 | let print_result rl = print_reg_list "[" "]" " ; " Register.print rl |
---|
38 | |
---|
39 | |
---|
40 | let print_statement = function |
---|
41 | | ERTL.St_skip lbl -> "--> " ^ lbl |
---|
42 | | ERTL.St_comment (s, lbl) -> |
---|
43 | Printf.sprintf "*** %s *** --> %s" s lbl |
---|
44 | | ERTL.St_cost (cost_lbl, lbl) -> |
---|
45 | let cost_lbl = CostLabel.string_of_cost_label ~pretty:true cost_lbl in |
---|
46 | Printf.sprintf "emit %s --> %s" cost_lbl lbl |
---|
47 | | ERTL.St_get_hdw (r1, r2, lbl) -> |
---|
48 | Printf.sprintf "move %s, %s --> %s" |
---|
49 | (Register.print r1) (I8051.print_register r2) lbl |
---|
50 | | ERTL.St_set_hdw (r1, r2, lbl) -> |
---|
51 | Printf.sprintf "move %s, %s --> %s" |
---|
52 | (I8051.print_register r1) (Register.print r2) lbl |
---|
53 | | ERTL.St_hdw_to_hdw (r1, r2, lbl) -> |
---|
54 | Printf.sprintf "move %s, %s --> %s" |
---|
55 | (I8051.print_register r1) (I8051.print_register r2) lbl |
---|
56 | | ERTL.St_newframe lbl -> |
---|
57 | Printf.sprintf "newframe --> %s" lbl |
---|
58 | | ERTL.St_delframe lbl -> |
---|
59 | Printf.sprintf "delframe --> %s" lbl |
---|
60 | | ERTL.St_framesize (r, lbl) -> |
---|
61 | Printf.sprintf "imm %s, FRAMESIZE --> %s" (Register.print r) lbl |
---|
62 | | ERTL.St_pop (r, lbl) -> |
---|
63 | Printf.sprintf "pop %s --> %s" (Register.print r) lbl |
---|
64 | | ERTL.St_push (r, lbl) -> |
---|
65 | Printf.sprintf "push %s --> %s" (Register.print r) lbl |
---|
66 | | ERTL.St_addrH (dstr, id, lbl) -> |
---|
67 | Printf.sprintf "addrH %s, %s --> %s" (Register.print dstr) id lbl |
---|
68 | | ERTL.St_addrL (dstr, id, lbl) -> |
---|
69 | Printf.sprintf "addrL %s, %s --> %s" (Register.print dstr) id lbl |
---|
70 | | ERTL.St_int (dstr, i, lbl) -> |
---|
71 | Printf.sprintf "imm %s, %d --> %s" (Register.print dstr) i lbl |
---|
72 | | ERTL.St_move (dstr, srcr, lbl) -> |
---|
73 | Printf.sprintf "move %s, %s --> %s" |
---|
74 | (Register.print dstr) (Register.print srcr) lbl |
---|
75 | | ERTL.St_opaccsA (opaccs, dstr, srcr1, srcr2, lbl) -> |
---|
76 | Printf.sprintf "%sA %s, %s, %s --> %s" |
---|
77 | (I8051.print_opaccs opaccs) |
---|
78 | (Register.print dstr) |
---|
79 | (Register.print srcr1) |
---|
80 | (Register.print srcr2) |
---|
81 | lbl |
---|
82 | | ERTL.St_opaccsB (opaccs, dstr, srcr1, srcr2, lbl) -> |
---|
83 | Printf.sprintf "%sB %s, %s, %s --> %s" |
---|
84 | (I8051.print_opaccs opaccs) |
---|
85 | (Register.print dstr) |
---|
86 | (Register.print srcr1) |
---|
87 | (Register.print srcr2) |
---|
88 | lbl |
---|
89 | | ERTL.St_op1 (op1, dstr, srcr, lbl) -> |
---|
90 | Printf.sprintf "%s %s, %s --> %s" |
---|
91 | (I8051.print_op1 op1) |
---|
92 | (Register.print dstr) |
---|
93 | (Register.print srcr) |
---|
94 | lbl |
---|
95 | | ERTL.St_op2 (op2, dstr, srcr1, srcr2, lbl) -> |
---|
96 | Printf.sprintf "%s %s, %s, %s --> %s" |
---|
97 | (I8051.print_op2 op2) |
---|
98 | (Register.print dstr) |
---|
99 | (Register.print srcr1) |
---|
100 | (Register.print srcr2) |
---|
101 | lbl |
---|
102 | | ERTL.St_clear_carry lbl -> |
---|
103 | Printf.sprintf "clear CARRY --> %s" lbl |
---|
104 | | ERTL.St_set_carry lbl -> |
---|
105 | Printf.sprintf "set CARRY --> %s" lbl |
---|
106 | | ERTL.St_load (dstr, addr1, addr2, lbl) -> |
---|
107 | Printf.sprintf "load %s, (%s, %s) --> %s" |
---|
108 | (Register.print dstr) |
---|
109 | (Register.print addr1) |
---|
110 | (Register.print addr2) |
---|
111 | lbl |
---|
112 | | ERTL.St_store (addr1, addr2, srcr, lbl) -> |
---|
113 | Printf.sprintf "store (%s, %s), %s --> %s" |
---|
114 | (Register.print addr1) |
---|
115 | (Register.print addr2) |
---|
116 | (Register.print srcr) |
---|
117 | lbl |
---|
118 | | ERTL.St_call_id (f, nb_args, lbl) -> |
---|
119 | Printf.sprintf "call \"%s\", %d --> %s" |
---|
120 | f |
---|
121 | nb_args |
---|
122 | lbl |
---|
123 | (* |
---|
124 | | ERTL.St_call_ptr (f, args, dstrs, lbl) -> |
---|
125 | Printf.sprintf "call_ptr %s, %s, %s --> %s" |
---|
126 | (print_ptr f) |
---|
127 | (print_args args) |
---|
128 | (print_return dstrs) |
---|
129 | lbl |
---|
130 | | ERTL.St_tailcall_id (f, nb_args) -> |
---|
131 | Printf.sprintf "tailcall \"%s\", %d" |
---|
132 | f |
---|
133 | nb_args |
---|
134 | | ERTL.St_tailcall_ptr (f, args) -> |
---|
135 | Printf.sprintf "tailcall_ptr %s, %s" |
---|
136 | (print_ptr f) |
---|
137 | (print_args args) |
---|
138 | *) |
---|
139 | | ERTL.St_cond (srcr, lbl_true, lbl_false) -> |
---|
140 | Printf.sprintf "branch %s <> 0 --> %s, %s" |
---|
141 | (Register.print srcr) lbl_true lbl_false |
---|
142 | | ERTL.St_return ret_regs -> |
---|
143 | Printf.sprintf "return %s" (print_return ret_regs) |
---|
144 | |
---|
145 | |
---|
146 | let print_graph n c = |
---|
147 | let f lbl stmt s = |
---|
148 | Printf.sprintf "%s%s: %s\n%s" |
---|
149 | (n_spaces n) |
---|
150 | lbl |
---|
151 | (print_statement stmt) |
---|
152 | s in |
---|
153 | Label.Map.fold f c "" |
---|
154 | |
---|
155 | |
---|
156 | let print_internal_decl n f def = |
---|
157 | |
---|
158 | Printf.sprintf |
---|
159 | "%s\"%s\" %d\n%slocals: %s\n%sstacksize: %d\n%sentry: %s\n%sexit: %s\n\n%s" |
---|
160 | (n_spaces n) |
---|
161 | f |
---|
162 | def.ERTL.f_params |
---|
163 | (n_spaces (n+2)) |
---|
164 | (print_locals def.ERTL.f_locals) |
---|
165 | (n_spaces (n+2)) |
---|
166 | def.ERTL.f_stacksize |
---|
167 | (n_spaces (n+2)) |
---|
168 | def.ERTL.f_entry |
---|
169 | (n_spaces (n+2)) |
---|
170 | def.ERTL.f_exit |
---|
171 | (print_graph (n+2) def.ERTL.f_graph) |
---|
172 | |
---|
173 | |
---|
174 | let print_external_decl n f def = |
---|
175 | Printf.sprintf "%sextern \"%s\": %s\n" |
---|
176 | (n_spaces n) |
---|
177 | f |
---|
178 | (Primitive.print_sig def.AST.ef_sig) |
---|
179 | |
---|
180 | |
---|
181 | let print_fun_decl n (f, def) = match def with |
---|
182 | | ERTL.F_int def -> print_internal_decl n f def |
---|
183 | | ERTL.F_ext def -> print_external_decl n f def |
---|
184 | |
---|
185 | let print_fun_decls n functs = |
---|
186 | List.fold_left (fun s f -> s ^ (print_fun_decl n f) ^ "\n\n") "" |
---|
187 | functs |
---|
188 | |
---|
189 | |
---|
190 | let print_program p = |
---|
191 | Printf.sprintf "program:\n\n\n%s\n\n%s" |
---|
192 | (print_globals 2 p.ERTL.vars) |
---|
193 | (print_fun_decls 2 p.ERTL.functs) |
---|