source: Deliverables/D2.2/8051-indexed-labels-branch/src/LIN/LINPrinter.ml @ 1392

(** This module provides a function to print [LIN] programs. *)


let n_spaces ?stmt n = 
        let n = match stmt with
                | Some (LIN.St_label _) | Some (LIN.St_cost _) -> n - 2
                | _ -> n in 
        String.make n ' '


let print_global n (x, size) =
  Printf.sprintf "%s\"%s\" [%d]" (n_spaces n) x size

let print_globals n globs =
  Printf.sprintf "%sglobals:\n%s"
    (n_spaces n)
    (List.fold_left (fun s g -> s ^ (print_global (n+2) g) ^ "\n") "" globs)


let print_reg = I8051.print_register

let print_a = print_reg I8051.a


let print_statement = function
  | LIN.St_goto lbl -> "goto " ^ lbl
  | LIN.St_label lbl -> lbl ^ ":"
  | LIN.St_comment s ->
    Printf.sprintf "*** %s ***" s
  | LIN.St_cost cost_lbl ->
    let cost_lbl = CostLabel.string_of_cost_label ~pretty:true cost_lbl in
                Printf.sprintf "emit %s" cost_lbl
  | LIN.St_ind_0 i ->
    Printf.sprintf "index %d" i
  | LIN.St_ind_inc i ->
    Printf.sprintf "increment %d" i
  | LIN.St_int (dstr, i) ->
    Printf.sprintf "imm %s, %d" (print_reg dstr) i
  | LIN.St_pop ->
    Printf.sprintf "pop %s" print_a
  | LIN.St_push ->
    Printf.sprintf "push %s" print_a
  | LIN.St_addr id ->
    Printf.sprintf "addr DPTR, %s" id
  | LIN.St_from_acc dstr ->
    Printf.sprintf "move %s, %s" (print_reg dstr) print_a
  | LIN.St_to_acc srcr ->
    Printf.sprintf "move %s, %s" print_a (print_reg srcr)
  | LIN.St_opaccs opaccs ->
    Printf.sprintf "%s %s, %s"
      (I8051.print_opaccs opaccs) print_a (print_reg I8051.b)
  | LIN.St_op1 op1 ->
    Printf.sprintf "%s %s" (I8051.print_op1 op1) print_a
  | LIN.St_op2 (op2, srcr) ->
    Printf.sprintf "%s %s, %s"
      (I8051.print_op2 op2) print_a (print_reg srcr)
  | LIN.St_clear_carry -> "clear CARRY"
  | LIN.St_set_carry -> "set CARRY"
  | LIN.St_load ->
    Printf.sprintf "movex %s, @DPTR" print_a
  | LIN.St_store ->
    Printf.sprintf "movex @DPTR, %s" print_a
  | LIN.St_call_id f -> Printf.sprintf "call \"%s\"" f
  | LIN.St_condacc lbl_true ->
    Printf.sprintf "branch %s <> 0, %s" print_a lbl_true
  | LIN.St_return -> "return"


let print_code n c =
  let f s stmt =
    Printf.sprintf "%s\n%s%s" s (n_spaces ~stmt:stmt n) (print_statement stmt) in
  List.fold_left f "" c


let print_internal_decl n f def =

  Printf.sprintf
    "%s\"%s\"\n\n%s"
    (n_spaces n)
    f
    (print_code (n+2) def)


let print_external_decl n f def =
  Printf.sprintf "%sextern \"%s\": %s\n"
    (n_spaces n)
    f
    (Primitive.print_sig def.AST.ef_sig)


let print_fun_decl n (f, def) = match def with
  | LIN.F_int def -> print_internal_decl n f def
  | LIN.F_ext def -> print_external_decl n f def

let print_fun_decls n functs =
  List.fold_left (fun s f -> s ^ (print_fun_decl n f) ^ "\n\n") ""
    functs


let print_program p =
  Printf.sprintf "program:\n\n\n%s\n\n%s"
    (print_globals 2 p.LIN.vars)
    (print_fun_decls 2 p.LIN.functs)

(*
(* Adapted from Pottier's PP compiler *)

open Printf
open PrintPottier
open LIN

let reg () r =
  sprintf "$%s" (MIPS.print r)

(*
let slo () = function
  | SlotLocal o ->
      sprintf "local(%ld)" o
  | SlotIncoming o ->
      sprintf "in(%ld)" o
  | SlotOutgoing o ->
      sprintf "out(%ld)" o
*)

let load_op () = function
  | AST.Byte -> "lb "
  | AST.HalfWord -> "lhw"
  | AST.Word -> "lw "

let store_op () = function
  | AST.Byte -> "sb "
  | AST.HalfWord -> "shw"
  | AST.Word -> "sw "

let instruction () i =

  match i with
    | INewFrame ->
        sprintf "newframe"
    | IDeleteFrame ->
        sprintf "delframe"
(*
    | IGetStack (destr, slot) ->
        sprintf "gets  %a, %a" reg destr slo slot
    | ISetStack (slot, sourcer) ->
        sprintf "sets  %a, %a" slo slot reg sourcer
*)
    | IConst (r, i) ->
        sprintf "li    %a, %ld" reg r i
    | IUnOp (op, destr, sourcer) ->
        sprintf "%a" (PrintOps.unop reg) (op, destr, sourcer)
    | IBinOp (op, destr, sourcer1, sourcer2) ->
        sprintf "%s %a, %a, %a" (PrintOps.binop op) reg destr reg sourcer1 reg sourcer2
    | ILoadAddr (r, f) ->
        sprintf "la    %a, %s" reg r f
    | ICall rf ->
        sprintf "call  %a" reg rf
    | ITailCall rf ->
        sprintf "tail  %a" reg rf
    | ILoad (size, destr, sourcer, offset) ->
        sprintf "%a   %a, %ld(%a)" load_op size reg destr offset reg sourcer
    | IStore (size, addressr, offset, valuer) ->
        sprintf "%a   %a, %ld(%a)" store_op size reg valuer offset reg addressr
    | IGoto l ->
        sprintf "j     %s" l
    | IUnBranch (cond, sourcer, l) ->
        sprintf "%a, %s" (PrintOps.uncon reg) (cond, sourcer) l
    | IBinBranch (cond, sourcer1, sourcer2, l) ->
        sprintf "%s %a, %a, %s" (PrintOps.bincon cond) reg sourcer1 reg sourcer2 l
    | IReturn ->
        sprintf "jr    $ra"
    | ILabel l ->
        sprintf "%s:" l
    | ICost l ->
        sprintf "%s:" l

let proc () (name, proc) = match proc with
  | LIN.F_int proc ->
      sprintf "procedure %s(%ld)\nvar %ld\n%a"
        name
        proc.formals
        proc.locals
        (seplist nl instruction) proc.code
  | LIN.F_ext proc ->
      sprintf "extern %s: %s\n" name (Primitive.print_sig proc.AST.ef_sig)

let map_to_association_list map =
  let f k v l = (k, v) :: l in
  StringTools.Map.fold f map []

let print_program () p =
  sprintf "program\n\nglobals %ld\n\n%a"
    p.globals
    (termlist nlnl proc) (map_to_association_list p.defs)
*)