source: Deliverables/D2.2/8051/src/LTL/LTLPrinter.ml @ 1568

Last change on this file since 1568 was 1568, checked in by tranquil, 8 years ago
  • Immediates introduced (but not fully used yet in RTLabs to RTL pass)
  • translation streamlined
  • BUGGY: interpretation fails in LTL, trying to fetch a function with incorrect address
File size: 3.4 KB
Line 
1
2(** This module provides a function to print [LTL] programs. *)
3
4
5let n_spaces n = String.make n ' '
6
7
8let print_global n (x, size) =
9  Printf.sprintf "%s\"%s\" [%d]" (n_spaces n) x size
10
11let 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
17let print_reg = I8051.print_register
18
19let print_a = print_reg I8051.a
20
21let print_arg = function
22  | LTL.Imm i -> string_of_int i
23  | LTL.Reg r -> print_reg r
24
25
26let print_statement = function
27  | LTL.St_skip lbl -> "--> " ^ lbl
28  | LTL.St_comment (s, lbl) ->
29    Printf.sprintf "*** %s *** --> %s" s lbl
30  | LTL.St_cost (cost_lbl, lbl) ->
31    let cost_lbl = CostLabel.string_of_cost_label ~pretty:true cost_lbl in
32    Printf.sprintf "emit %s --> %s" cost_lbl lbl
33  | LTL.St_ind_0 (i, lbl) ->
34    Printf.sprintf "index %d --> %s" i lbl
35  | LTL.St_ind_inc (i, lbl) ->
36    Printf.sprintf "increment %d --> %s" i lbl
37  | LTL.St_int (dstr, i, lbl) ->
38    Printf.sprintf "imm %s, %d --> %s" (print_reg dstr) i lbl
39  | LTL.St_pop lbl ->
40    Printf.sprintf "pop %s --> %s" print_a lbl
41  | LTL.St_push lbl ->
42    Printf.sprintf "push %s --> %s" print_a lbl
43  | LTL.St_addr (id, lbl) ->
44    Printf.sprintf "addr DPTR, %s --> %s" id lbl
45  | LTL.St_from_acc (dstr, lbl) ->
46    Printf.sprintf "move %s, %s --> %s" (print_reg dstr) print_a lbl
47  | LTL.St_to_acc (srcr, lbl) ->
48    Printf.sprintf "move %s, %s --> %s" print_a (print_reg srcr) lbl
49  | LTL.St_opaccs (opaccs, lbl) ->
50    Printf.sprintf "%s %s, %s --> %s"
51      (I8051.print_opaccs opaccs) print_a (print_reg I8051.b) lbl
52  | LTL.St_op1 (op1, lbl) ->
53    Printf.sprintf "%s %s --> %s" (I8051.print_op1 op1) print_a lbl
54  | LTL.St_op2 (op2, srcr, lbl) ->
55    Printf.sprintf "%s %s, %s --> %s"
56      (I8051.print_op2 op2) print_a (print_arg srcr) lbl
57  | LTL.St_clear_carry lbl ->
58    Printf.sprintf "clear CARRY --> %s" lbl
59  | LTL.St_set_carry lbl ->
60    Printf.sprintf "set CARRY --> %s" lbl
61  | LTL.St_load lbl ->
62    Printf.sprintf "movex %s, @DPTR --> %s" print_a lbl
63  | LTL.St_store lbl ->
64    Printf.sprintf "movex @DPTR, %s --> %s" print_a lbl
65  | LTL.St_call_id (f, lbl) -> Printf.sprintf "call \"%s\" --> %s" f lbl
66  | LTL.St_call_ptr lbl ->
67    Printf.sprintf "call_ptr DPTR --> %s" lbl
68  | LTL.St_condacc (lbl_true, lbl_false) ->
69    Printf.sprintf "branch %s <> 0 --> %s, %s" print_a lbl_true lbl_false
70  | LTL.St_return -> Printf.sprintf "return"
71
72
73let print_graph n c =
74  let f lbl stmt s =
75    Printf.sprintf "%s%s: %s\n%s"
76      (n_spaces n)
77      lbl
78      (print_statement stmt)
79      s in
80  Label.Map.fold f c ""
81
82
83let print_internal_decl n f def =
84
85  Printf.sprintf
86    "%s\"%s\"\n%sstacksize: %d\n%sentry: %s\n%sexit: %s\n\n%s"
87    (n_spaces n)
88    f
89    (n_spaces (n+2))
90    def.LTL.f_stacksize
91    (n_spaces (n+2))
92    def.LTL.f_entry
93    (n_spaces (n+2))
94    def.LTL.f_exit
95    (print_graph (n+2) def.LTL.f_graph)
96
97
98let print_external_decl n f def =
99  Printf.sprintf "%sextern \"%s\": %s\n"
100    (n_spaces n)
101    f
102    (Primitive.print_sig def.AST.ef_sig)
103
104
105let print_fun_decl n (f, def) = match def with
106  | LTL.F_int def -> print_internal_decl n f def
107  | LTL.F_ext def -> print_external_decl n f def
108
109let print_fun_decls n functs =
110  List.fold_left (fun s f -> s ^ (print_fun_decl n f) ^ "\n\n") ""
111    functs
112
113
114let print_program p =
115  Printf.sprintf "program:\n\n\n%s\n\n%s"
116    (print_globals 2 p.LTL.vars)
117    (print_fun_decls 2 p.LTL.functs)
Note: See TracBrowser for help on using the repository browser.