2 (** This module provides a function to print [RTL] programs. *)
5 let n_spaces n = String.make n ' '
8 let print_global n (x, size) =
9 Printf.sprintf "%s\"%s\" [%d]" (n_spaces n) x size
11 let print_globals eformat n globs =
12 Eformat.printf eformat "%sglobals:\n" (n_spaces n) ;
14 (fun g -> Eformat.printf eformat "%s\n" (print_global (n+2) g)) globs
16 let print_reg = Register.print
18 let reg_set_to_list rs =
20 Register.Set.iter (fun r -> e := r :: !e) rs;
23 let print_reg_list first last sep f rl =
24 Printf.sprintf "%s%s%s"
25 first (MiscPottier.string_of_list sep f rl) last
27 let print_ptr rl = print_reg_list "[" "]" " ; " print_reg rl
29 let print_args rl = print_reg_list "(" ")" ", " print_reg rl
31 let print_return rl = print_reg_list "[" "]" " ; " print_reg rl
33 let print_params rl = print_reg_list "(" ")" ", " Register.print rl
36 let rl = reg_set_to_list rs in
37 Printf.sprintf "%s" (print_reg_list "" "" ", " Register.print rl)
39 let print_result rl = print_reg_list "[" "]" " ; " Register.print rl
42 let print_statement = function
43 | RTL.St_skip lbl -> "--> " ^ lbl
44 | RTL.St_cost (cost_lbl, lbl) ->
45 Printf.sprintf "emit %s --> %s" cost_lbl lbl
46 | RTL.St_addr (dstr1, dstr2, id, lbl) ->
47 Printf.sprintf "imm (%s, %s), %s --> %s"
48 (print_reg dstr1) (print_reg dstr2) id lbl
49 | RTL.St_stackaddr (dstr1, dstr2, lbl) ->
50 Printf.sprintf "imm (%s, %s), STACK --> %s"
51 (print_reg dstr1) (print_reg dstr2) lbl
52 | RTL.St_int (dstr, i, lbl) ->
53 Printf.sprintf "imm %s, %d --> %s" (print_reg dstr) i lbl
54 | RTL.St_move (dstr, srcr, lbl) ->
55 Printf.sprintf "move %s, %s --> %s"
56 (print_reg dstr) (print_reg srcr) lbl
57 | RTL.St_opaccs (opaccs, dstr1, dstr2, srcr1, srcr2, lbl) ->
58 Printf.sprintf "%s (%s, %s) %s, %s --> %s"
59 (I8051.print_opaccs opaccs)
65 | RTL.St_op1 (op1, dstr, srcr, lbl) ->
66 Printf.sprintf "%s %s, %s --> %s"
67 (I8051.print_op1 op1) (print_reg dstr) (print_reg srcr) lbl
68 | RTL.St_op2 (op2, dstr, srcr1, srcr2, lbl) ->
69 Printf.sprintf "%s %s, %s, %s --> %s"
75 | RTL.St_clear_carry lbl ->
76 Printf.sprintf "clear CARRY --> %s" lbl
77 | RTL.St_set_carry lbl ->
78 Printf.sprintf "set CARRY --> %s" lbl
79 | RTL.St_load (dstr, addr1, addr2, lbl) ->
80 Printf.sprintf "load %s, (%s, %s) --> %s"
85 | RTL.St_store (addr1, addr2, srcr, lbl) ->
86 Printf.sprintf "store (%s, %s), %s --> %s"
91 | RTL.St_call_id (f, args, dstrs, lbl) ->
92 Printf.sprintf "call \"%s\", %s, %s --> %s"
97 | RTL.St_call_ptr (f1, f2, args, dstrs, lbl) ->
98 Printf.sprintf "call_ptr [%s ; %s], %s, %s --> %s"
104 | RTL.St_tailcall_id (f, args) ->
105 Printf.sprintf "tailcall \"%s\", %s"
108 | RTL.St_tailcall_ptr (f1, f2, args) ->
109 Printf.sprintf "tailcall_ptr [%s ; %s], %s"
113 | RTL.St_cond (srcr, lbl_true, lbl_false) ->
114 Printf.sprintf "branch %s <> 0 --> %s, %s"
115 (print_reg srcr) lbl_true lbl_false
116 | RTL.St_return regs ->
117 Printf.sprintf "return %s" (print_return regs)
120 let print_graph eformat n c =
122 Eformat.printf eformat "%s%s: %s\n"
125 (print_statement stmt) in
129 let print_internal_decl eformat n f def =
130 Eformat.printf eformat
131 "%s\"%s\"%s\n%slocals: %s\n%sresult: %s\n%sstacksize: %d\n%sentry: %s\n%sexit: %s\n\n"
134 (print_params def.RTL.f_params)
136 (print_locals def.RTL.f_locals)
138 (print_result def.RTL.f_result)
145 print_graph eformat (n+2) def.RTL.f_graph
148 let print_external_decl eformat n f def =
149 Eformat.printf eformat "%sextern \"%s\": %s\n"
152 (Primitive.print_sig def.AST.ef_sig)
155 let print_fun_decl eformat n (f, def) = match def with
156 | RTL.F_int def -> print_internal_decl eformat n f def
157 | RTL.F_ext def -> print_external_decl eformat n f def
159 let print_fun_decls eformat n functs =
161 (fun f -> print_fun_decl eformat n f ; Eformat.printf eformat "\n\n")
165 let print_program p =
166 let eformat = Eformat.create () in
167 Eformat.printf eformat "program:\n\n\n" ;
168 print_globals eformat 2 p.RTL.vars ;
169 Eformat.printf eformat "\n\n" ;
170 print_fun_decls eformat 2 p.RTL.functs ;