src/RTLabs/RTLabsPrinter.ml

   1
   2 let n_spaces n = String.make n ' '
   3
   4
   5 let rec print_size = function
   6   | AST.SQ q -> Memory.string_of_quantity q
   7   | AST.SProd l -> "struct {" ^ (print_size_list l) ^ "}"
   8   | AST.SSum l -> "union {" ^ (print_size_list l) ^ "}"
   9   | AST.SArray (i, se) ->
  10     (print_size se) ^ "[" ^ (string_of_int i) ^ "]"
  11 and print_size_list l =
  12   MiscPottier.string_of_list ", " print_size l
  13
  14 let print_global_size = print_size
  15
  16 let print_data = function
  17 (*
  18   | Data_reserve n -> Printf.sprintf "[%d]" n
  19 *)
  20   | AST.Data_int8 i -> Printf.sprintf "(int8) %d" i
  21   | AST.Data_int16 i -> Printf.sprintf "(int16) %d" i
  22   | AST.Data_int32 i -> Printf.sprintf "%d" i
  23   | AST.Data_float32 f -> Printf.sprintf "%f" f
  24   | AST.Data_float64 f -> Printf.sprintf "(float64) %f" f
  25
  26 let print_datas init =
  27   let rec aux = function
  28     | [] -> ""
  29     | [data] -> print_data data
  30     | data :: datas -> Printf.sprintf "%s, %s" (print_data data) (aux datas)
  31   in
  32   Printf.sprintf "{%s}" (aux init)
  33
  34 let print_datas_opt = function
  35   | None -> ""
  36   | Some init -> " = " ^ (print_datas init)
  37
  38 let print_global n (id, size, init_opt) =
  39   Printf.sprintf "%s\"%s\" : %s%s;\n"
  40     (n_spaces n) id (print_global_size size) (print_datas_opt init_opt)
  41
  42 let print_globals eformat n =
  43   List.iter (fun v -> Eformat.printf eformat "%s" (print_global n v))
  44
  45
  46 let print_reg = Register.print
  47
  48 let print_oreg = function
  49   | None -> "_"
  50   | Some r -> print_reg r
  51
  52 let print_decl (r, t) =
  53   (Primitive.print_type t) ^ " " ^ (Register.print r)
  54
  55 let rec print_args args =
  56   Printf.sprintf "[%s]" (MiscPottier.string_of_list ", " print_reg args)
  57
  58 let print_result = function
  59   | None -> "_"
  60   | Some (r, t) -> (Primitive.print_type t) ^ " " ^ (Register.print r)
  61
  62 let print_params r =
  63   Printf.sprintf "(%s)" (MiscPottier.string_of_list ", " print_decl r)
  64
  65 let print_locals r =
  66   Printf.sprintf "%s" (MiscPottier.string_of_list ", " print_decl r)
  67
  68
  69 let print_cmp = function
  70   | AST.Cmp_eq -> "eq"
  71   | AST.Cmp_ne -> "ne"
  72   | AST.Cmp_gt -> "gt"
  73   | AST.Cmp_ge -> "ge"
  74   | AST.Cmp_lt -> "lt"
  75   | AST.Cmp_le -> "le"
  76
  77 let rec print_size = function
  78   | AST.SQ q -> Memory.string_of_quantity q
  79   | AST.SProd l -> "struct {" ^ (print_size_list l) ^ "}"
  80   | AST.SSum l -> "union {" ^ (print_size_list l) ^ "}"
  81   | AST.SArray (i, se) ->
  82     (print_size se) ^ "[" ^ (string_of_int i) ^ "]"
  83 and print_size_list l =
  84   MiscPottier.string_of_list ", " print_size l
  85
  86 let print_stacksize = print_size
  87
  88 let print_offset (size, depth) =
  89   (print_size size) ^ ", " ^ (string_of_int depth)
  90
  91 let print_sizeof = print_size
  92
  93 let print_cst = function
  94   | AST.Cst_int i -> Printf.sprintf "imm_int %d" i
  95   | AST.Cst_float f -> Printf.sprintf "imm_float %f" f
  96   | AST.Cst_addrsymbol id -> Printf.sprintf "imm_addr \"%s\"" id
  97   | AST.Cst_stack -> "imm_addr STACK"
  98   | AST.Cst_offset off -> Printf.sprintf "imm_offset { %s }" (print_offset off)
  99   | AST.Cst_sizeof t -> "imm_sizeof (" ^ (print_size t) ^ ")"
 100
 101 let string_of_signedness = function
 102   | AST.Signed -> "s"
 103   | AST.Unsigned -> "u"
 104
 105 let string_of_int_type (size, sign) =
 106   Printf.sprintf "%d%s" size (string_of_signedness sign)
 107
 108 let print_op1 = function
 109   | AST.Op_cast (int_type, dest_size) ->
 110     Printf.sprintf "int%sto%d" (string_of_int_type int_type) dest_size
 111   | AST.Op_negint -> "negint"
 112   | AST.Op_notbool -> "notbool"
 113   | AST.Op_notint -> "notint"
 114   | AST.Op_id -> "id"
 115   | AST.Op_ptrofint -> "ptrofint"
 116   | AST.Op_intofptr -> "intofptr"
 117
 118 let print_op2 = function
 119   | AST.Op_add -> "add"
 120   | AST.Op_sub -> "sub"
 121   | AST.Op_mul -> "mul"
 122   | AST.Op_div -> "div"
 123   | AST.Op_divu -> "/u"
 124   | AST.Op_mod -> "mod"
 125   | AST.Op_modu -> "modu"
 126   | AST.Op_and -> "and"
 127   | AST.Op_or -> "or"
 128   | AST.Op_xor -> "xor"
 129   | AST.Op_shl -> "shl"
 130   | AST.Op_shr -> "shr"
 131   | AST.Op_shru -> "shru"
 132   | AST.Op_cmp cmp -> print_cmp cmp
 133   | AST.Op_addp -> "addp"
 134   | AST.Op_subp -> "subp"
 135   | AST.Op_subpp -> "subpp"
 136   | AST.Op_cmpp cmp -> (print_cmp cmp) ^ "p"
 137   | AST.Op_cmpu cmp -> (print_cmp cmp) ^ "u"
 138
 139
 140 (*
 141 let print_addressing = function
 142   | RTLabs.Aindexed off -> Printf.sprintf "{ %s }" (print_offset off)
 143   | RTLabs.Aindexed2 -> "add"
 144   | RTLabs.Aglobal (id, off) ->
 145     Printf.sprintf "{ %s }(\"%s\")" (print_offset off) id
 146   | RTLabs.Abased (id, off) ->
 147     Printf.sprintf "add, { %s }(\"%s\")" (print_offset off) id
 148   | RTLabs.Ainstack off -> Printf.sprintf "{ %s }(STACK)" (print_offset off)
 149 *)
 150
 151
 152 let rec print_table = function
 153   | [] -> ""
 154   | [lbl] -> lbl
 155   | lbl :: tbl -> lbl ^ ", " ^ (print_table tbl)
 156
 157
 158 let print_statement = function
 159   | RTLabs.St_skip lbl -> "--> " ^ lbl
 160   | RTLabs.St_cost (cost_lbl, lbl) ->
 161       Printf.sprintf "emit %s --> %s" cost_lbl lbl
 162   | RTLabs.St_cst (destr, cst, lbl) ->
 163       Printf.sprintf "imm %s, %s --> %s"
 164         (print_reg destr)
 165         (print_cst cst)
 166         lbl
 167   | RTLabs.St_op1 (op1, destr, srcr, lbl) ->
 168       Printf.sprintf "%s %s, %s --> %s"
 169         (print_op1 op1)
 170         (print_reg destr)
 171         (print_reg srcr)
 172         lbl
 173   | RTLabs.St_op2 (op2, destr, srcr1, srcr2, lbl) ->
 174       Printf.sprintf "%s %s, %s, %s --> %s"
 175         (print_op2 op2)
 176         (print_reg destr)
 177         (print_reg srcr1)
 178         (print_reg srcr2)
 179         lbl
 180   | RTLabs.St_load (q, addr, destr, lbl) ->
 181       Printf.sprintf "load %s, %s, %s --> %s"
 182         (Memory.string_of_quantity q)
 183         (print_reg addr)
 184         (print_reg destr)
 185         lbl
 186   | RTLabs.St_store (q, addr, srcr, lbl) ->
 187       Printf.sprintf "store %s, %s, %s --> %s"
 188         (Memory.string_of_quantity q)
 189         (print_reg addr)
 190         (print_reg srcr)
 191         lbl
 192   | RTLabs.St_call_id (f, args, res, sg, lbl) ->
 193       Printf.sprintf "call \"%s\", %s, %s: %s --> %s"
 194         f
 195         (print_args args)
 196         (print_oreg res)
 197         (Primitive.print_sig sg)
 198         lbl
 199   | RTLabs.St_call_ptr (f, args, res, sg, lbl) ->
 200       Printf.sprintf "call_ptr %s, %s, %s: %s --> %s"
 201         (print_reg f)
 202         (print_args args)
 203         (print_oreg res)
 204         (Primitive.print_sig sg)
 205         lbl
 206   | RTLabs.St_tailcall_id (f, args, sg) ->
 207       Printf.sprintf "tailcall \"%s\", %s: %s"
 208         f
 209         (print_args args)
 210         (Primitive.print_sig sg)
 211   | RTLabs.St_tailcall_ptr (f, args, sg) ->
 212       Printf.sprintf "tailcall_ptr \"%s\", %s: %s"
 213         (print_reg f)
 214         (print_args args)
 215         (Primitive.print_sig sg)
 216   | RTLabs.St_cond (r, lbl_true, lbl_false) ->
 217       Printf.sprintf "%s? --> %s, %s"
 218         (print_reg r)
 219         lbl_true
 220         lbl_false
 221 (*
 222   | RTLabs.St_condcst (cst, t, lbl_true, lbl_false) ->
 223       Printf.sprintf "(%s) %s --> %s, %s"
 224         (Primitive.print_type t)
 225         (print_cst cst)
 226         lbl_true
 227         lbl_false
 228   | RTLabs.St_cond1 (op1, srcr, lbl_true, lbl_false) ->
 229       Printf.sprintf "%s %s --> %s, %s"
 230         (print_op1 op1)
 231         (print_reg srcr)
 232         lbl_true
 233         lbl_false
 234   | RTLabs.St_cond2 (op2, srcr1, srcr2, lbl_true, lbl_false) ->
 235       Printf.sprintf "%s %s, %s --> %s, %s"
 236         (print_op2 op2)
 237         (print_reg srcr1)
 238         (print_reg srcr2)
 239         lbl_true
 240         lbl_false
 241 *)
 242   | RTLabs.St_jumptable (r, tbl) ->
 243       Printf.sprintf "j_tbl %s --> %s"
 244         (print_reg r)
 245         (print_table tbl)
 246   | RTLabs.St_return None -> Printf.sprintf "return"
 247   | RTLabs.St_return (Some r) -> Printf.sprintf "return %s" (print_reg r)
 248
 249
 250 let print_graph eformat n c =
 251   let f lbl stmt =
 252     Eformat.printf eformat "%s%s: %s\n"
 253       (n_spaces n)
 254       lbl
 255       (print_statement stmt) in
 256   Label.Map.iter f c
 257
 258
 259 let print_internal_decl eformat n f def =
 260   Eformat.printf eformat
 261     "%s\"%s\"%s\n%slocals: %s\n%sresult: %s\n%sstacksize: %s\n%sentry: %s\n%sexit: %s\n\n"
 262     (n_spaces n)
 263     f
 264     (print_params def.RTLabs.f_params)
 265     (n_spaces (n+2))
 266     (print_locals def.RTLabs.f_locals)
 267     (n_spaces (n+2))
 268     (print_result def.RTLabs.f_result)
 269     (n_spaces (n+2))
 270     (print_stacksize def.RTLabs.f_stacksize)
 271     (n_spaces (n+2))
 272     def.RTLabs.f_entry
 273     (n_spaces (n+2))
 274     def.RTLabs.f_exit ;
 275   print_graph eformat (n+2) def.RTLabs.f_graph
 276
 277
 278 let print_external_decl eformat n f def =
 279   Eformat.printf eformat "%sextern \"%s\": %s\n"
 280     (n_spaces n)
 281     f
 282     (Primitive.print_sig def.AST.ef_sig)
 283
 284
 285 let print_fun_decl eformat n (f, def) = match def with
 286   | RTLabs.F_int def -> print_internal_decl eformat n f def
 287   | RTLabs.F_ext def -> print_external_decl eformat n f def
 288
 289 let print_fun_decls eformat n functs =
 290   List.iter
 291     (fun f -> print_fun_decl eformat n f ; Eformat.printf eformat "\n\n")
 292     functs
 293
 294
 295 let print_program p =
 296   let eformat = Eformat.create () in
 297   Eformat.printf eformat "program:\n\n\n" ;
 298   print_globals eformat 2 p.RTLabs.vars ;
 299   Eformat.printf eformat "\n\n" ;
 300   print_fun_decls eformat 2 p.RTLabs.functs ;
 301   Eformat.get eformat