src/LTL/LTLPrinter.ml

   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 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 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 eformat n c =
  65   let f lbl stmt =
  66     Eformat.printf eformat "%s%s: %s\n"
  67       (n_spaces n)
  68       lbl
  69       (print_statement stmt) in
  70   Label.Map.iter f c
  71
  72
  73 let print_internal_decl eformat n f def =
  74   Eformat.printf eformat
  75     "%s\"%s\"\n%sstacksize: %d\n%sentry: %s\n%sexit: %s\n\n"
  76     (n_spaces n)
  77     f
  78     (n_spaces (n+2))
  79     def.LTL.f_stacksize
  80     (n_spaces (n+2))
  81     def.LTL.f_entry
  82     (n_spaces (n+2))
  83     def.LTL.f_exit ;
  84   print_graph eformat (n+2) def.LTL.f_graph
  85
  86
  87 let print_external_decl eformat n f def =
  88   Eformat.printf eformat "%sextern \"%s\": %s\n"
  89     (n_spaces n)
  90     f
  91     (Primitive.print_sig def.AST.ef_sig)
  92
  93
  94 let print_fun_decl eformat n (f, def) = match def with
  95   | LTL.F_int def -> print_internal_decl eformat n f def
  96   | LTL.F_ext def -> print_external_decl eformat n f def
  97
  98 let print_fun_decls eformat n functs =
  99   List.iter
 100     (fun f -> print_fun_decl eformat n f ; Eformat.printf eformat "\n\n")
 101     functs
 102
 103
 104 let print_program p =
 105   let eformat = Eformat.create () in
 106   Eformat.printf eformat "program:\n\n\n" ;
 107   print_globals eformat 2 p.LTL.vars ;
 108   Eformat.printf eformat "\n\n" ;
 109   print_fun_decls eformat 2 p.LTL.functs ;
 110   Eformat.get eformat