src/RTL/RTLPrinter.ml

   1
   2 (** This module provides a function to print [RTL] 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 let print_reg = Register.print
  17
  18 let reg_set_to_list rs =
  19   let e = ref [] in
  20   Register.Set.iter (fun r -> e := r :: !e) rs;
  21   List.rev !e
  22
  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
  26
  27 let print_ptr rl = print_reg_list "[" "]" " ; " print_reg rl
  28
  29 let print_args rl = print_reg_list "(" ")" ", " print_reg rl
  30
  31 let print_return rl = print_reg_list "[" "]" " ; " print_reg rl
  32
  33 let print_params rl = print_reg_list "(" ")" ", " Register.print rl
  34
  35 let print_locals rs =
  36   let rl = reg_set_to_list rs in
  37   Printf.sprintf "%s" (print_reg_list "" "" ", " Register.print rl)
  38
  39 let print_result rl = print_reg_list "[" "]" " ; " Register.print rl
  40
  41
  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)
  60       (print_reg dstr1)
  61       (print_reg dstr2)
  62       (print_reg srcr1)
  63       (print_reg srcr2)
  64       lbl
  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"
  70       (I8051.print_op2 op2)
  71       (print_reg dstr)
  72       (print_reg srcr1)
  73       (print_reg srcr2)
  74       lbl
  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"
  81       (print_reg dstr)
  82       (print_reg addr1)
  83       (print_reg addr2)
  84       lbl
  85   | RTL.St_store (addr1, addr2, srcr, lbl) ->
  86     Printf.sprintf "store (%s, %s), %s --> %s"
  87       (print_reg addr1)
  88       (print_reg addr2)
  89       (print_reg srcr)
  90       lbl
  91   | RTL.St_call_id (f, args, dstrs, lbl) ->
  92     Printf.sprintf "call \"%s\", %s, %s --> %s"
  93       f
  94       (print_args args)
  95       (print_return dstrs)
  96       lbl
  97   | RTL.St_call_ptr (f1, f2, args, dstrs, lbl) ->
  98     Printf.sprintf "call_ptr [%s ; %s], %s, %s --> %s"
  99       (print_reg f1)
 100       (print_reg f2)
 101       (print_args args)
 102       (print_return dstrs)
 103       lbl
 104   | RTL.St_tailcall_id (f, args) ->
 105     Printf.sprintf "tailcall \"%s\", %s"
 106       f
 107       (print_args args)
 108   | RTL.St_tailcall_ptr (f1, f2, args) ->
 109     Printf.sprintf "tailcall_ptr [%s ; %s], %s"
 110       (print_reg f1)
 111       (print_reg f2)
 112       (print_args args)
 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)
 118
 119
 120 let print_graph eformat n c =
 121   let f lbl stmt =
 122     Eformat.printf eformat "%s%s: %s\n"
 123       (n_spaces n)
 124       lbl
 125       (print_statement stmt) in
 126   Label.Map.iter f c
 127
 128
 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"
 132     (n_spaces n)
 133     f
 134     (print_params def.RTL.f_params)
 135     (n_spaces (n+2))
 136     (print_locals def.RTL.f_locals)
 137     (n_spaces (n+2))
 138     (print_result def.RTL.f_result)
 139     (n_spaces (n+2))
 140     def.RTL.f_stacksize
 141     (n_spaces (n+2))
 142     def.RTL.f_entry
 143     (n_spaces (n+2))
 144     def.RTL.f_exit ;
 145   print_graph eformat (n+2) def.RTL.f_graph
 146
 147
 148 let print_external_decl eformat n f def =
 149   Eformat.printf eformat "%sextern \"%s\": %s\n"
 150     (n_spaces n)
 151     f
 152     (Primitive.print_sig def.AST.ef_sig)
 153
 154
 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
 158
 159 let print_fun_decls eformat n functs =
 160   List.iter
 161     (fun f -> print_fun_decl eformat n f ; Eformat.printf eformat "\n\n")
 162     functs
 163
 164
 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 ;
 171   Eformat.get eformat