(** This module translates a [LIN] program into a [ASM] program. *)


let error_prefix = "LIN to ASM"
let error s = Error.global_error error_prefix s


(* Translation environment *)

type env =
    { externals : AST.ident list ;
      exit_lbl : Label.t ;
      fresh : unit -> string }

let make_env externals exit_lbl fresh =
  { externals = externals ;
    exit_lbl = exit_lbl ;
    fresh = fresh }


(* Fetch the labels found in a LIN program. *)

let statement_labels = function
  | LIN.St_goto lbl
  | LIN.St_label lbl
  | LIN.St_cost lbl
  | LIN.St_condacc lbl -> Label.Set.singleton lbl
  | _ -> Label.Set.empty

let funct_labels (_, fun_def) = match fun_def with
  | LIN.F_int stmts ->
    let f labels stmt = Label.Set.union labels (statement_labels stmt) in
    List.fold_left f Label.Set.empty stmts
  | _ -> Label.Set.empty

let prog_labels p =
  let f labels funct = Label.Set.union labels (funct_labels funct) in
  List.fold_left f Label.Set.empty p.LIN.functs


let size_of_vect_size = function
  | `Four -> 4
  | `Seven -> 7
  | `Eight -> 8
  | `Eleven -> 11
  | `Sixteen -> 16

let vect_of_int i size =
  let i' =
    if i < 0 then (MiscPottier.pow 2 (size_of_vect_size size)) + i else i in
  try BitVectors.vect_of_int i' size
  with Invalid_argument _ (* "BitVectors.vect_of_int: size not big enough" *) ->
    error
      (Printf.sprintf "integer %d is too big to convert using %d bits. Maybe the stack frame of a function is too big."
	 i (size_of_vect_size size))

let byte_of_int i = vect_of_int i `Eight
let data_of_int i = `DATA (byte_of_int i)
let data16_of_int i = `DATA16 (vect_of_int i `Sixteen)
let acc_addr = I8051.reg_addr I8051.a
let dpl_addr = I8051.reg_addr I8051.dpl
let dph_addr = I8051.reg_addr I8051.dph
let st0_addr = I8051.reg_addr I8051.st0
let st1_addr = I8051.reg_addr I8051.st1


let translate_statement env = function
  | LIN.St_goto lbl -> [`Jmp lbl]
  | LIN.St_label lbl -> [`Label lbl]
  | LIN.St_comment _ -> []
  | LIN.St_cost lbl ->
    (* TODO: hack! Need to make the difference between cost labels and regular
       labels. *)
    [`Cost lbl ; `NOP]
  | LIN.St_int (r, i) ->
    [`MOV (`U3 (I8051.reg_addr r, data_of_int i))]
  | LIN.St_pop ->
    [`POP acc_addr]
  | LIN.St_push ->
    [`PUSH acc_addr]
  | LIN.St_addr x when List.mem x env.externals ->
    (* HACK! for Lustre support: externals appears in the code but are not
       used. *)
    [`MOV (`U4 (`DPTR, data16_of_int 0))]
  (* error ("Primitive or external " ^ x ^ " is not supported.") *)
  | LIN.St_addr x ->
    [`Mov (`DPTR, x)]
  | LIN.St_from_acc r ->
    [`MOV (`U3 (I8051.reg_addr r, `A))]
  | LIN.St_to_acc r ->
    [`MOV (`U1 (`A, I8051.reg_addr r))]
  | LIN.St_opaccs I8051.Mul ->
    [`MUL (`A, `B)]
  | LIN.St_opaccs I8051.DivuModu ->
    [`DIV (`A, `B)]
  | LIN.St_op1 I8051.Cmpl ->
    [`CPL `A]
  | LIN.St_op1 I8051.Inc ->
    [`INC `A]
  | LIN.St_op2 (I8051.Add, r) ->
    [`ADD (`A, I8051.reg_addr r)]
  | LIN.St_op2 (I8051.Addc, r) ->
    [`ADDC (`A, I8051.reg_addr r)]
  | LIN.St_op2 (I8051.Sub, r) ->
    [`SUBB (`A, I8051.reg_addr r)]
  | LIN.St_op2 (I8051.And, r) ->
    [`ANL (`U1 (`A, I8051.reg_addr r))]
  | LIN.St_op2 (I8051.Or, r) ->
    [`ORL (`U1 (`A, I8051.reg_addr r))]
  | LIN.St_op2 (I8051.Xor, r) ->
    [`XRL (`U1 (`A, I8051.reg_addr r))]
  | LIN.St_clear_carry ->
    [`CLR `C]
  | LIN.St_set_carry ->
    [`SETB `C]
  | LIN.St_load ->
    [`MOVX (`U1 (`A, `EXT_IND_DPTR))]
  | LIN.St_store ->
    [`MOVX (`U2 (`EXT_IND_DPTR, `A))]
  | LIN.St_call_id x when List.mem x env.externals ->
    (* HACK! for Lustre support: externals appears in the code but are not
       used. *)
    []
  (* error ("Primitive or external " ^ x ^ " is not supported.") *)
  | LIN.St_call_id f ->
    [`Call f]
  | LIN.St_call_ptr ->
    let lbl = env.fresh () in
    [`MOV (`U3 (st0_addr, dpl_addr)) ; (* save DPL *)
     `MOV (`U3 (st1_addr, dph_addr)) ; (* save DPH *)
     `Mov (`DPTR, lbl) ;               (* DPTR <- return address *)
     `PUSH dpl_addr ;                  (* push DPL *)
     `PUSH dph_addr ;                  (* push DPH *)
     `MOV (`U3 (dpl_addr, st0_addr)) ; (* restore DPL *)
     `MOV (`U3 (dph_addr, st1_addr)) ; (* restore DPH *)
     `MOV (`U1 (`A, data_of_int 0)) ;  (* A <- 0 *)
     `JMP `IND_DPTR ;                  (* jump to A+DPTR *)
     `Label lbl]                       (* return address *)
  | LIN.St_condacc lbl ->
    [`WithLabel (`JNZ (`Label lbl))]
  | LIN.St_return ->
    [`RET]

let translate_code env code =
  List.flatten (List.map (translate_statement env) code)


let translate_fun_def env (id, def) =
  let code = match def with
  | LIN.F_int code -> translate_code env code
  | LIN.F_ext ext -> [`NOP] in
  ((`Label id) :: code)

let translate_functs env main functs =
  let preamble = match main with
    | None -> []
    | Some main ->
      [`MOV (`U3 (`DIRECT (byte_of_int I8051.isp_addr),
		  data_of_int I8051.isp_init)) ;
       `MOV (`U3 (`DIRECT (byte_of_int I8051.spl_addr),
		  data_of_int I8051.spl_init)) ;
       `MOV (`U3 (`DIRECT (byte_of_int I8051.sph_addr),
		  data_of_int I8051.sph_init)) ;
       `Call main ;
       `Label env.exit_lbl ; `Jmp env.exit_lbl] in
  preamble @ (List.flatten (List.map (translate_fun_def env) functs))


let init_env p =
  let f_externals (id, def) = match def with LIN.F_ext _ -> [id] | _ -> [] in
  let externals =
    List.fold_left (fun res def -> res @ (f_externals def)) [] p.LIN.functs in
  let prog_lbls = prog_labels p in
  let exit_lbl = Label.Gen.fresh_prefix prog_lbls "_exit" in
  let fresh = Label.make_fresh prog_lbls "_call_ret" in
  make_env externals exit_lbl fresh


(* Translating programs.

   Global variables are associated an offset from the base of the external
   memory. *)

let translate p =
  let env = init_env p in
  let p =
    { ASM.ppreamble = p.LIN.vars ;
      ASM.pexit_label = env.exit_lbl ;
      ASM.pcode = translate_functs env p.LIN.main p.LIN.functs ;
      ASM.phas_main = p.LIN.main <> None } in
  ASMInterpret.assembly p