1 | |
---|
2 | (** This module provides a function to print [LTL] 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 print_reg = I8051.print_register |
---|
18 | |
---|
19 | let print_a = print_reg I8051.a |
---|
20 | |
---|
21 | |
---|
22 | let print_statement = function |
---|
23 | | LTL.St_skip lbl -> "--> " ^ lbl |
---|
24 | | LTL.St_comment (s, lbl) -> |
---|
25 | Printf.sprintf "*** %s *** --> %s" s lbl |
---|
26 | | LTL.St_cost (cost_lbl, lbl) -> |
---|
27 | Printf.sprintf "emit %s --> %s" cost_lbl lbl |
---|
28 | | LTL.St_int (dstr, i, lbl) -> |
---|
29 | Printf.sprintf "imm %s, %d --> %s" (print_reg dstr) i lbl |
---|
30 | | LTL.St_pop lbl -> |
---|
31 | Printf.sprintf "pop %s --> %s" print_a lbl |
---|
32 | | LTL.St_push lbl -> |
---|
33 | Printf.sprintf "push %s --> %s" print_a lbl |
---|
34 | | LTL.St_addr (id, lbl) -> |
---|
35 | Printf.sprintf "addr DPTR, %s --> %s" id lbl |
---|
36 | | LTL.St_from_acc (dstr, lbl) -> |
---|
37 | Printf.sprintf "move %s, %s --> %s" (print_reg dstr) print_a lbl |
---|
38 | | LTL.St_to_acc (srcr, lbl) -> |
---|
39 | Printf.sprintf "move %s, %s --> %s" print_a (print_reg srcr) lbl |
---|
40 | | LTL.St_opaccs (opaccs, lbl) -> |
---|
41 | Printf.sprintf "%s %s, %s --> %s" |
---|
42 | (I8051.print_opaccs opaccs) print_a (print_reg I8051.b) lbl |
---|
43 | | LTL.St_op1 (op1, lbl) -> |
---|
44 | Printf.sprintf "%s %s --> %s" (I8051.print_op1 op1) print_a lbl |
---|
45 | | LTL.St_op2 (op2, srcr, lbl) -> |
---|
46 | Printf.sprintf "%s %s, %s --> %s" |
---|
47 | (I8051.print_op2 op2) print_a (print_reg srcr) lbl |
---|
48 | | LTL.St_clear_carry lbl -> |
---|
49 | Printf.sprintf "clear CARRY --> %s" lbl |
---|
50 | | LTL.St_set_carry lbl -> |
---|
51 | Printf.sprintf "set CARRY --> %s" lbl |
---|
52 | | LTL.St_load lbl -> |
---|
53 | Printf.sprintf "movex %s, @DPTR --> %s" print_a lbl |
---|
54 | | LTL.St_store lbl -> |
---|
55 | Printf.sprintf "movex @DPTR, %s --> %s" print_a lbl |
---|
56 | | LTL.St_call_id (f, lbl) -> Printf.sprintf "call \"%s\" --> %s" f lbl |
---|
57 | | LTL.St_call_ptr lbl -> |
---|
58 | Printf.sprintf "call_ptr DPTR --> %s" lbl |
---|
59 | | LTL.St_condacc (lbl_true, lbl_false) -> |
---|
60 | Printf.sprintf "branch %s <> 0 --> %s, %s" print_a lbl_true lbl_false |
---|
61 | | LTL.St_return -> Printf.sprintf "return" |
---|
62 | |
---|
63 | |
---|
64 | let print_graph n c = |
---|
65 | let f lbl stmt s = |
---|
66 | Printf.sprintf "%s%s: %s\n%s" |
---|
67 | (n_spaces n) |
---|
68 | lbl |
---|
69 | (print_statement stmt) |
---|
70 | s in |
---|
71 | Label.Map.fold f c "" |
---|
72 | |
---|
73 | |
---|
74 | let print_internal_decl n f def = |
---|
75 | |
---|
76 | Printf.sprintf |
---|
77 | "%s\"%s\"\n%sstacksize: %d\n%sentry: %s\n%sexit: %s\n\n%s" |
---|
78 | (n_spaces n) |
---|
79 | f |
---|
80 | (n_spaces (n+2)) |
---|
81 | def.LTL.f_stacksize |
---|
82 | (n_spaces (n+2)) |
---|
83 | def.LTL.f_entry |
---|
84 | (n_spaces (n+2)) |
---|
85 | def.LTL.f_exit |
---|
86 | (print_graph (n+2) def.LTL.f_graph) |
---|
87 | |
---|
88 | |
---|
89 | let print_external_decl n f def = |
---|
90 | Printf.sprintf "%sextern \"%s\": %s\n" |
---|
91 | (n_spaces n) |
---|
92 | f |
---|
93 | (Primitive.print_sig def.AST.ef_sig) |
---|
94 | |
---|
95 | |
---|
96 | let print_fun_decl n (f, def) = match def with |
---|
97 | | LTL.F_int def -> print_internal_decl n f def |
---|
98 | | LTL.F_ext def -> print_external_decl n f def |
---|
99 | |
---|
100 | let print_fun_decls n functs = |
---|
101 | List.fold_left (fun s f -> s ^ (print_fun_decl n f) ^ "\n\n") "" |
---|
102 | functs |
---|
103 | |
---|
104 | |
---|
105 | let print_program p = |
---|
106 | Printf.sprintf "program:\n\n\n%s\n\n%s" |
---|
107 | (print_globals 2 p.LTL.vars) |
---|
108 | (print_fun_decls 2 p.LTL.functs) |
---|