src/ERTL/ERTLPrinter.ml

   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 eformat n globs =
  12   Eformat.printf eformat "%sglobals:\n" (n_spaces n) ;
  13   List.iter
  14     (fun g -> Eformat.printf eformat "%s\n" (print_global (n+2) g)) 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     Printf.sprintf "emit %s --> %s" cost_lbl lbl
  46   | ERTL.St_get_hdw (r1, r2, lbl) ->
  47     Printf.sprintf "move %s, %s --> %s"
  48       (Register.print r1) (I8051.print_register r2) lbl
  49   | ERTL.St_set_hdw (r1, r2, lbl) ->
  50     Printf.sprintf "move %s, %s --> %s"
  51       (I8051.print_register r1) (Register.print r2) lbl
  52   | ERTL.St_hdw_to_hdw (r1, r2, lbl) ->
  53     Printf.sprintf "move %s, %s --> %s"
  54       (I8051.print_register r1) (I8051.print_register r2) lbl
  55   | ERTL.St_newframe lbl ->
  56     Printf.sprintf "newframe --> %s" lbl
  57   | ERTL.St_delframe lbl ->
  58     Printf.sprintf "delframe --> %s" lbl
  59   | ERTL.St_framesize (r, lbl) ->
  60     Printf.sprintf "imm %s, FRAMESIZE --> %s" (Register.print r) lbl
  61   | ERTL.St_pop (r, lbl) ->
  62     Printf.sprintf "pop %s --> %s" (Register.print r) lbl
  63   | ERTL.St_push (r, lbl) ->
  64     Printf.sprintf "push %s --> %s" (Register.print r) lbl
  65   | ERTL.St_addrH (dstr, id, lbl) ->
  66     Printf.sprintf "addrH %s, %s --> %s" (Register.print dstr) id lbl
  67   | ERTL.St_addrL (dstr, id, lbl) ->
  68     Printf.sprintf "addrL %s, %s --> %s" (Register.print dstr) id lbl
  69   | ERTL.St_int (dstr, i, lbl) ->
  70     Printf.sprintf "imm %s, %d --> %s" (Register.print dstr) i lbl
  71   | ERTL.St_move (dstr, srcr, lbl) ->
  72     Printf.sprintf "move %s, %s --> %s"
  73       (Register.print dstr) (Register.print srcr) lbl
  74   | ERTL.St_opaccsA (opaccs, dstr, srcr1, srcr2, lbl) ->
  75     Printf.sprintf "%sA %s, %s, %s --> %s"
  76       (I8051.print_opaccs opaccs)
  77       (Register.print dstr)
  78       (Register.print srcr1)
  79       (Register.print srcr2)
  80       lbl
  81   | ERTL.St_opaccsB (opaccs, dstr, srcr1, srcr2, lbl) ->
  82     Printf.sprintf "%sB %s, %s, %s --> %s"
  83       (I8051.print_opaccs opaccs)
  84       (Register.print dstr)
  85       (Register.print srcr1)
  86       (Register.print srcr2)
  87       lbl
  88   | ERTL.St_op1 (op1, dstr, srcr, lbl) ->
  89     Printf.sprintf "%s %s, %s --> %s"
  90       (I8051.print_op1 op1)
  91       (Register.print dstr)
  92       (Register.print srcr)
  93       lbl
  94   | ERTL.St_op2 (op2, dstr, srcr1, srcr2, lbl) ->
  95     Printf.sprintf "%s %s, %s, %s --> %s"
  96       (I8051.print_op2 op2)
  97       (Register.print dstr)
  98       (Register.print srcr1)
  99       (Register.print srcr2)
 100       lbl
 101   | ERTL.St_clear_carry lbl ->
 102     Printf.sprintf "clear CARRY --> %s" lbl
 103   | ERTL.St_set_carry lbl ->
 104     Printf.sprintf "set CARRY --> %s" lbl
 105   | ERTL.St_load (dstr, addr1, addr2, lbl) ->
 106     Printf.sprintf "load %s, (%s, %s) --> %s"
 107       (Register.print dstr)
 108       (Register.print addr1)
 109       (Register.print addr2)
 110       lbl
 111   | ERTL.St_store (addr1, addr2, srcr, lbl) ->
 112     Printf.sprintf "store (%s, %s), %s --> %s"
 113       (Register.print addr1)
 114       (Register.print addr2)
 115       (Register.print srcr)
 116       lbl
 117   | ERTL.St_call_id (f, nb_args, lbl) ->
 118     Printf.sprintf "call \"%s\", %d --> %s" f nb_args lbl
 119   | ERTL.St_call_ptr (f1, f2, nb_args, lbl) ->
 120     Printf.sprintf "call_ptr [%s ; %s], %d --> %s"
 121       (Register.print f1)
 122       (Register.print f2)
 123       nb_args
 124       lbl
 125 (*
 126   | ERTL.St_tailcall_id (f, nb_args) ->
 127     Printf.sprintf "tailcall \"%s\", %d"
 128       f
 129       nb_args
 130   | ERTL.St_tailcall_ptr (f, args) ->
 131     Printf.sprintf "tailcall_ptr %s, %s"
 132       (print_ptr f)
 133       (print_args args)
 134 *)
 135   | ERTL.St_cond (srcr, lbl_true, lbl_false) ->
 136     Printf.sprintf "branch %s <> 0 --> %s, %s"
 137       (Register.print srcr) lbl_true lbl_false
 138   | ERTL.St_return ret_regs ->
 139     Printf.sprintf "return %s" (print_return ret_regs)
 140
 141
 142 let print_graph eformat n c =
 143   let f lbl stmt =
 144     Eformat.printf eformat "%s%s: %s\n"
 145       (n_spaces n)
 146       lbl
 147       (print_statement stmt) in
 148   Label.Map.iter f c
 149
 150
 151 let print_internal_decl eformat n f def =
 152   Eformat.printf eformat
 153     "%s\"%s\" %d\n%slocals: %s\n%sstacksize: %d\n%sentry: %s\n%sexit: %s\n\n"
 154     (n_spaces n)
 155     f
 156     def.ERTL.f_params
 157     (n_spaces (n+2))
 158     (print_locals def.ERTL.f_locals)
 159     (n_spaces (n+2))
 160     def.ERTL.f_stacksize
 161     (n_spaces (n+2))
 162     def.ERTL.f_entry
 163     (n_spaces (n+2))
 164     def.ERTL.f_exit ;
 165   print_graph eformat (n+2) def.ERTL.f_graph
 166
 167
 168 let print_external_decl eformat n f def =
 169   Eformat.printf eformat "%sextern \"%s\": %s\n"
 170     (n_spaces n)
 171     f
 172     (Primitive.print_sig def.AST.ef_sig)
 173
 174
 175 let print_fun_decl eformat n (f, def) = match def with
 176   | ERTL.F_int def -> print_internal_decl eformat n f def
 177   | ERTL.F_ext def -> print_external_decl eformat n f def
 178
 179 let print_fun_decls eformat n functs =
 180   List.iter
 181     (fun f -> print_fun_decl eformat n f ; Eformat.printf eformat "\n\n")
 182     functs
 183
 184
 185 let print_program p =
 186   let eformat = Eformat.create () in
 187   Eformat.printf eformat "program:\n\n\n" ;
 188   print_globals eformat 2 p.ERTL.vars ;
 189   Eformat.printf eformat "\n\n" ;
 190   print_fun_decls eformat 2 p.ERTL.functs ;
 191   Eformat.get eformat