printer.ml

   1 let print_keyword =
   2  function
   3   | Extracted.Joint_printer.KwCOMMENT      -> "COMMENT"
   4   | Extracted.Joint_printer.KwMOVE         -> "MOVE"
   5   | Extracted.Joint_printer.KwPOP          -> "POP"
   6   | Extracted.Joint_printer.KwPUSH         -> "PUSH"
   7   | Extracted.Joint_printer.KwADDRESS      -> "ADDRESS"
   8   | Extracted.Joint_printer.KwOPACCS       -> "OPACCS"
   9   | Extracted.Joint_printer.KwOP1          -> "OP1"
  10   | Extracted.Joint_printer.KwOP2          -> "OP2"
  11   | Extracted.Joint_printer.KwCLEAR_CARRY  -> "CLEAR_CARRY"
  12   | Extracted.Joint_printer.KwSET_CARRY    -> "SET_CARRY"
  13   | Extracted.Joint_printer.KwLOAD         -> "LOAD"
  14   | Extracted.Joint_printer.KwSTORE        -> "STORE"
  15   | Extracted.Joint_printer.KwCOST_LABEL   -> "COST_LABEL"
  16   | Extracted.Joint_printer.KwCOND         -> "COND"
  17   | Extracted.Joint_printer.KwCALL         -> "CALL"
  18   | Extracted.Joint_printer.KwGOTO         -> "GOTO"
  19   | Extracted.Joint_printer.KwRETURN       -> "RETURN"
  20   | Extracted.Joint_printer.KwTAILCALL     -> "TAILCALL"
  21   | Extracted.Joint_printer.KwFCOND        -> "FCOND"
  22
  23 let print_opAccs =
  24  function
  25   | Extracted.BackEndOps.Mul -> "Mul"
  26   | Extracted.BackEndOps.DivuModu -> "DivModu"
  27
  28 let print_op1 =
  29  function
  30   | Extracted.BackEndOps.Cmpl -> "Cmpl"
  31   | Extracted.BackEndOps.Inc -> "Inc"
  32   | Extracted.BackEndOps.Rl -> "Rl"
  33
  34 let print_op2 =
  35  function
  36   | Extracted.BackEndOps.Add -> "Add"
  37   | Extracted.BackEndOps.Addc -> "Addc"
  38   | Extracted.BackEndOps.Sub -> "Sub"
  39   | Extracted.BackEndOps.And -> "And"
  40   | Extracted.BackEndOps.Or -> "Or"
  41   | Extracted.BackEndOps.Xor -> "Xor"
  42
  43 (* Duplicated, also in cerco.ml! *)
  44 let string_of_pos n = string_of_int (Extracted.Glue.int_of_matitapos n)
  45
  46 let print_ident n = "fun_" ^ string_of_pos n
  47
  48 let printing_pass_independent_params =
  49  { Extracted.Joint_printer.print_String =
  50     (fun Extracted.String.EmptyString -> "EmptyString")
  51  ; print_keyword = print_keyword
  52  ; print_concat = (fun s1 s2 -> s1 ^ " " ^ s2)
  53  ; print_empty = ""
  54  ; print_ident = print_ident
  55  ; print_costlabel = (fun n -> "k_" ^ string_of_pos n)
  56  ; print_label = (fun n -> "l_" ^ string_of_pos n)
  57  ; print_OpAccs = print_opAccs
  58  ; print_Op1 = print_op1
  59  ; print_Op2 = print_op2
  60  ; print_nat = (fun n -> string_of_int (Extracted.Glue.int_of_matitanat n))
  61  ; print_bitvector = (fun _ n -> string_of_int (Extracted.Glue.int_of_bitvector n))
  62  }
  63
  64 let print_byte b = string_of_int (IntelHex.int_of_vect b)
  65
  66 let print_argument print_arg =
  67  function
  68     Extracted.Joint.Imm b -> print_byte b
  69   | Extracted.Joint.Reg x -> print_arg x
  70
  71 let print_Register =
  72  function
  73   | Extracted.I8051.Register00     -> "Register00"
  74   | Extracted.I8051.Register01     -> "Register01"
  75   | Extracted.I8051.Register02     -> "Register02"
  76   | Extracted.I8051.Register03     -> "Register03"
  77   | Extracted.I8051.Register04     -> "Register04"
  78   | Extracted.I8051.Register05     -> "Register05"
  79   | Extracted.I8051.Register06     -> "Register06"
  80   | Extracted.I8051.Register07     -> "Register07"
  81   | Extracted.I8051.Register10     -> "Register10"
  82   | Extracted.I8051.Register11     -> "Register11"
  83   | Extracted.I8051.Register12     -> "Register12"
  84   | Extracted.I8051.Register13     -> "Register13"
  85   | Extracted.I8051.Register14     -> "Register14"
  86   | Extracted.I8051.Register15     -> "Register15"
  87   | Extracted.I8051.Register16     -> "Register16"
  88   | Extracted.I8051.Register17     -> "Register17"
  89   | Extracted.I8051.Register20     -> "Register20"
  90   | Extracted.I8051.Register21     -> "Register21"
  91   | Extracted.I8051.Register22     -> "Register22"
  92   | Extracted.I8051.Register23     -> "Register23"
  93   | Extracted.I8051.Register24     -> "Register24"
  94   | Extracted.I8051.Register25     -> "Register25"
  95   | Extracted.I8051.Register26     -> "Register26"
  96   | Extracted.I8051.Register27     -> "Register27"
  97   | Extracted.I8051.Register30     -> "Register30"
  98   | Extracted.I8051.Register31     -> "Register31"
  99   | Extracted.I8051.Register32     -> "Register32"
 100   | Extracted.I8051.Register33     -> "Register33"
 101   | Extracted.I8051.Register34     -> "Register34"
 102   | Extracted.I8051.Register35     -> "Register35"
 103   | Extracted.I8051.Register36     -> "Register36"
 104   | Extracted.I8051.Register37     -> "Register37"
 105   | Extracted.I8051.RegisterA      -> "RegisterA"
 106   | Extracted.I8051.RegisterB      -> "RegisterB"
 107   | Extracted.I8051.RegisterDPL    -> "RegisterDPL"
 108   | Extracted.I8051.RegisterDPH    -> "RegisterDPH"
 109   | Extracted.I8051.RegisterCarry  -> "RegisterCarry"
 110
 111 let print_registers_move =
 112  function
 113   | Extracted.Joint_LTL_LIN.From_acc (reg,_unit) ->
 114      print_Register reg ^ " " ^ "ACC_A"
 115   | Extracted.Joint_LTL_LIN.To_acc (_unit,reg) ->
 116      "ACC_A " ^ print_Register reg
 117   | Extracted.Joint_LTL_LIN.Int_to_reg (reg,byte) ->
 118      print_Register reg ^ " " ^ print_byte byte
 119   | Extracted.Joint_LTL_LIN.Int_to_acc (_unit,byte) ->
 120      "ACC_A " ^ print_byte byte
 121
 122 let print_register n = "r_" ^ string_of_pos n
 123
 124 let rTL_printing_params =
 125  { Extracted.Joint_printer.print_pass_ind = printing_pass_independent_params
 126  ; print_acc_a_reg = Obj.magic print_register
 127  ; print_acc_b_reg = Obj.magic print_register
 128  ; print_acc_a_arg = Obj.magic (print_argument print_register)
 129  ; print_acc_b_arg = Obj.magic (print_argument print_register)
 130  ; print_dpl_reg = Obj.magic print_register
 131  ; print_dph_reg = Obj.magic print_register
 132  ; print_dpl_arg = Obj.magic (print_argument print_register)
 133  ; print_dph_arg = Obj.magic (print_argument print_register)
 134  ; print_snd_arg = Obj.magic (print_argument print_register)
 135  ; print_pair_move = Obj.magic
 136     (fun {Extracted.Types.fst = reg; snd = arg} ->
 137       print_register reg ^ " " ^ print_argument print_register arg)
 138  ; print_call_args = Obj.magic
 139     (fun l -> String.concat " " (List.map (print_argument print_register) l))
 140  ; print_call_dest = Obj.magic
 141     (fun l -> String.concat " " (List.map print_register l))
 142  ; print_ext_seq =
 143     (fun ext ->
 144       match Obj.magic ext with
 145        Extracted.RTL.Rtl_stack_address (reg1,reg2) ->
 146         "Rtl_stack_address " ^ print_register reg1 ^ " " ^ print_register reg2)
 147  }
 148
 149 let print_move_dst =
 150  function
 151     Extracted.ERTL.PSD reg -> print_register reg
 152   | Extracted.ERTL.HDW reg -> print_Register reg
 153
 154 let eRTL_printing_params =
 155  { Extracted.Joint_printer.print_pass_ind = printing_pass_independent_params
 156  ; print_acc_a_reg = Obj.magic print_register
 157  ; print_acc_b_reg = Obj.magic print_register
 158  ; print_acc_a_arg = Obj.magic (print_argument print_register)
 159  ; print_acc_b_arg = Obj.magic (print_argument print_register)
 160  ; print_dpl_reg = Obj.magic print_register
 161  ; print_dph_reg = Obj.magic print_register
 162  ; print_dpl_arg = Obj.magic (print_argument print_register)
 163  ; print_dph_arg = Obj.magic (print_argument print_register)
 164  ; print_snd_arg = Obj.magic (print_argument print_register)
 165  ; print_pair_move = Obj.magic
 166     (fun {Extracted.Types.fst = dst; snd = src} ->
 167       print_move_dst dst ^ " " ^ print_argument print_move_dst src )
 168  ; print_call_args =
 169     Obj.magic (fun n -> string_of_int (Extracted.Glue.int_of_matitanat n))
 170  ; print_call_dest = (fun _ -> "")
 171  ; print_ext_seq =
 172      (fun ext -> match Obj.magic ext with
 173      | Extracted.ERTL.Ertl_new_frame -> "NEW FRAME"
 174      | Extracted.ERTL.Ertl_del_frame -> "DEL FRAME"
 175      | Extracted.ERTL.Ertl_frame_size r -> "FRAMESIZE " ^ print_register r)
 176  }
 177
 178 let joint_LTL_LIN_printing_params =
 179  { Extracted.Joint_printer.print_pass_ind = printing_pass_independent_params
 180  ; print_acc_a_reg = (fun _ -> "ACC_A")
 181  ; print_acc_b_reg = (fun _ -> "ACC_B")
 182  ; print_acc_a_arg = (fun _ -> "ACC_A")
 183  ; print_acc_b_arg = (fun _ -> "ACC_B")
 184  ; print_dpl_reg = (fun _ -> "DPL")
 185  ; print_dph_reg = (fun _ -> "DPH")
 186  ; print_dpl_arg = (fun _ -> "DPL")
 187  ; print_dph_arg = (fun _ -> "DPH")
 188  ; print_snd_arg = (fun hdw_arg -> print_argument print_Register (Obj.magic hdw_arg))
 189  ; print_pair_move = Obj.magic print_registers_move
 190  ; print_call_args =
 191     (fun n ->string_of_int (Extracted.Glue.int_of_matitanat (Obj.magic n)))
 192  ; print_call_dest = (fun _ -> "")
 193  ; print_ext_seq =
 194      (fun ext -> match Obj.magic ext with
 195      | Extracted.Joint_LTL_LIN.SAVE_CARRY -> "SAVE_CARRY"
 196      | Extracted.Joint_LTL_LIN.RESTORE_CARRY -> "RESTORE_CARRY"
 197      |  Extracted.Joint_LTL_LIN.HIGH_ADDRESS l ->
 198        Format.sprintf "HIGH_ADDRESS l_%d" (Extracted.Glue.int_of_matitapos l)
 199      |  Extracted.Joint_LTL_LIN.LOW_ADDRESS l ->
 200        Format.sprintf "LOW_ADDRESS l_%d" (Extracted.Glue.int_of_matitapos l))
 201  }
 202
 203 let rec list_of_matitalist =
 204  function
 205     Extracted.List.Nil -> []
 206   | Extracted.List.Cons (hd,tl) -> hd :: list_of_matitalist tl
 207
 208 let print_graph l =
 209  let l = list_of_matitalist l in
 210   String.concat "\n\n"
 211    (List.map
 212      (fun {Extracted.Types.fst=ident; snd=commands} ->
 213        let commands = list_of_matitalist commands in
 214        print_ident ident ^ ":\n" ^
 215        String.concat "\n" (List.rev commands)
 216      )
 217     l)
 218
 219 let extension_of_pass =
 220  function
 221  | Extracted.Compiler.Clight_pass                -> "clight"
 222  | Extracted.Compiler.Clight_switch_removed_pass -> "clight_sr"
 223  | Extracted.Compiler.Clight_label_pass          -> "clight_l"
 224  | Extracted.Compiler.Clight_simplified_pass     -> "clight_s"
 225  | Extracted.Compiler.Cminor_pass                -> "cminor"
 226  | Extracted.Compiler.Rtlabs_pass                -> "rtlabs"
 227  | Extracted.Compiler.Rtl_separate_pass          -> "rtl"
 228  | Extracted.Compiler.Rtl_uniq_pass              -> "rtl_u"
 229  | Extracted.Compiler.Ertl_pass                  -> "ertl"
 230  | Extracted.Compiler.Ltl_pass                   -> "ltl"
 231  | Extracted.Compiler.Lin_pass                   -> "lin"
 232  | Extracted.Compiler.Assembly_pass              -> "assembly"
 233  | Extracted.Compiler.Object_code_pass           -> "hex"
 234 ;;
 235
 236
 237 let print_program sourcename pass (program : Extracted.Preamble.__) =
 238  let beprint pcs =
 239   print_graph (pcs (Extracted.Types.fst (Obj.magic program))) in
 240  let lines =
 241   match pass with
 242    | Extracted.Compiler.Clight_pass
 243    | Extracted.Compiler.Clight_switch_removed_pass
 244    | Extracted.Compiler.Clight_label_pass
 245    | Extracted.Compiler.Clight_simplified_pass ->
 246       ClightPrinter.print_program ClightPrinter.Cost_plain (Obj.magic program)
 247    | Extracted.Compiler.Rtlabs_pass ->
 248       RTLabsPrinter.print_program (Obj.magic program)
 249    | Extracted.Compiler.Rtl_separate_pass ->
 250       beprint (Extracted.RTL_printer.print_RTL_program rTL_printing_params)
 251    | Extracted.Compiler.Rtl_uniq_pass ->
 252       beprint (Extracted.RTL_printer.print_RTL_program rTL_printing_params)
 253    | Extracted.Compiler.Ertl_pass ->
 254       beprint (Extracted.ERTL_printer.print_ERTL_program eRTL_printing_params)
 255    | Extracted.Compiler.Ltl_pass ->
 256       beprint
 257        (Extracted.LTL_printer.print_LTL_program joint_LTL_LIN_printing_params)
 258    | Extracted.Compiler.Lin_pass ->
 259       beprint
 260        (Extracted.LIN_printer.print_LIN_program joint_LTL_LIN_printing_params)
 261    | Extracted.Compiler.Object_code_pass ->
 262       ASMPrinter.print_program (Obj.magic program)
 263    | _ -> ""
 264  in
 265   let filename =
 266    Filename.chop_extension sourcename ^ "." ^ extension_of_pass pass in
 267   let och = open_out filename in
 268   output_string och lines;
 269   close_out och