(*
   translate.ml
   15-411
   by Roland Flury
*)
(* @version $Id: translate.ml,v 1.4 2004/11/01 09:21:32 ajo Exp $ *)

(*
   This module translates abstract syntax trees (|absyn|) to the
   intermediate representation (|ir|).
*)


module A = Absyn
module HA = Hashtbl
module IR = Ir open Ir
module TP = Temp

exception TranslateError of string
exception InternalError

type trexp = Ex of IR.exp
           | Nx of IR.stmt
           | Cx of ((IR.label * IR.label) -> IR.stmt)

let intConst n = IR.CONST(Int32.of_int n)
let nullExp = IR.NAME ".Lnullptr"


let rec list_index f = function
  | [] -> raise Not_found
  | h::t -> if (f h) then 0 else (1+(list_index f t))

let unEx = function
  | Ex(e) -> e
  | Nx(s) -> raise (TranslateError "unEx(Nx(s))")
  | Cx(f) -> (
      let lt = IR.simpLabel() in
      let lf = IR.simpLabel() in
      let lend = IR.simpLabel() in
      let t = TP.simpTemp() in
      IR.ESEQ(IR.seq_of [
        f(lt, lf);
        IR.LABEL lt;
        IR.MOVE(IR.TEMP t, intConst 1);
        IR.JUMP lend;
        IR.LABEL lf;
        IR.MOVE(IR.TEMP t, intConst 0);
        IR.LABEL lend
      ], IR.TEMP t)
    )

let unNx = function
  | Ex(e) -> IR.EXP(e)
  | Nx(s) -> s
  | Cx(f) -> IR.EXP(unEx(Cx(f)))

let unCx = function
  | Ex(e) -> (function (a1,a2) -> IR.CJUMP(IR.JZ, e, intConst 0, a2, a1))
  | Nx(e) -> raise (TranslateError "unCx(Nx(s))")
  | Cx(f) -> f


(*************************************************************************)
(* Translate Expressions *)
(*************************************************************************)

let prog_end_label: label ref = ref ""

let mem_of e = IR.UNOP(A.DEREF, e)

let newptr e =
  IR.MOVE(e, IR.CALLOP("_alloc", [intConst 12]))
  

let copyptr e oldp = (
    let t1 = IR.TEMP(TP.simpTemp()) in
    let t2 = IR.TEMP(TP.simpTemp()) in
    IR.seq_of [
      newptr t1;
      IR.MOVE(t2, oldp);
      IR.MOVE(mem_of t1, mem_of t2);
      IR.MOVE(mem_of(IR.BINOP(A.PLUS, t1, intConst 4)),
              mem_of(IR.BINOP(A.PLUS, t2, intConst 4)));
      IR.MOVE(mem_of(IR.BINOP(A.PLUS, t1, intConst 8)),
              mem_of(IR.BINOP(A.PLUS, t2, intConst 8)));
      IR.MOVE(e, t1)
    ]
  )


let trans_program (A.Program(tli, dli, sli)) = (

  let getTypedclFromStructName id = (
    List.find (fun (A.Typedcl(s,_,_)) -> (s = id)) tli
  ) in

  let rec init_ir (whence, tv) = (
    match tv with
    | A.StructT sn -> (
        let A.Typedcl(sn, mli, _) = getTypedclFromStructName sn in
        let ssize = List.length mli in
        let rec init_members n = function
          | [] -> []
          | (_,mtv)::t -> (
              let mwhence =
                mem_of(BINOP(A.PLUS, whence, intConst(4*n)))
              in init_ir(mwhence, mtv) :: (init_members (n+1) t)
            )
        in
        seq_of (
          MOVE(whence, CALLOP("_alloc", [intConst(4*ssize)]))
          :: (init_members 0 mli)
        )
      )
    | A.PtrT _ -> MOVE(whence, nullExp)
    | _ -> NOTHING
  ) in


let rec trans_exp = function
  | A.IntConstExp(n,_,_) -> Ex(CONST n)
  | A.BoolConstExp(true,_,_) -> Ex(intConst 1)
  | A.BoolConstExp(false,_,_) -> Ex(intConst 0)
  | A.NullConstExp(_,_) -> Ex(nullExp)
  | A.VarExp(id,_,_) -> Ex(Frame.localIR id)
  | A.UnOpExp(A.OFFSET,e,_,_) ->
      Ex(mem_of(BINOP(A.PLUS, unEx(trans_exp e), intConst 4)))
  | A.UnOpExp(A.SIZE,e,_,_) ->
      Ex(mem_of(BINOP(A.PLUS, unEx(trans_exp e), intConst 8)))
  | A.UnOpExp(A.DEREF,e,_,_) -> (
      let tbase = TEMP(TP.simpTemp())
      and toffset = TEMP(TP.simpTemp())
      and tresult = TEMP(TP.simpTemp())
      and linrange = simpLabel()
      and loutofrange = simpLabel() in
      Ex(ESEQ(seq_of [
        MOVE(tbase, unEx(trans_exp e));
        MOVE(toffset, mem_of(BINOP(A.PLUS, tbase, intConst 4)));
        CJUMP(JB, toffset, mem_of(BINOP(A.PLUS, tbase, intConst 8)),
              linrange, loutofrange);
        LABEL(loutofrange);
        (*
           Failure code: call a magic function to report the error.
             We supply a dummy parameter in case we ever want to give
           the line number of the error in future revisions of the
           compiler.  We also supply the bad pointer itself, so we
           can take appropriate action.
        *)
        EXP(CALLOP("_null_dereference", [intConst 0; tbase]));
        LABEL(linrange);
        MOVE(tresult, BINOP(A.PLUS, mem_of(tbase),
                                   BINOP(A.TIMES, toffset, intConst 4)))
      ],
      mem_of tresult))
    )
  | A.UnOpExp(A.LOGNEGATE,e,_,_) ->
      Cx(function (lt,lf) -> unCx(trans_exp e)(lf, lt))
  | A.UnOpExp(op,e,_,_) -> Ex(UNOP(op, unEx(trans_exp e)))

  | A.BinOpExp(e1,A.PTRPLUS,e2,_,tv) -> begin
      let tp = TEMP(TP.simpTemp())
      and ti = TEMP(TP.simpTemp())
      and lnull = simpLabel()
      and lnotnull = simpLabel()
      and lend = simpLabel()
      in Ex(ESEQ(seq_of [
        MOVE(tp, unEx(trans_exp e1));
        MOVE(ti, unEx(trans_exp e2));
        CJUMP(JZ, tp, nullExp, lnull, lnotnull);
        LABEL(lnull);
        MOVE(tp, nullExp);
        JUMP(lend);
        LABEL(lnotnull);
        copyptr tp tp;
        MOVE(mem_of(BINOP(A.PLUS, tp, intConst 4)),
             BINOP(A.PLUS, mem_of(BINOP(A.PLUS, tp, intConst 4)), ti)
            );
        LABEL(lend)
      ], tp))
    end

  | A.BinOpExp(e1,A.PTRMINUS,e2,_,tv) -> begin
      let tp = TEMP(TP.simpTemp())
      and ti = TEMP(TP.simpTemp())
      and lnull = simpLabel()
      and lnotnull = simpLabel()
      and lend = simpLabel()
      in Ex(ESEQ(seq_of [
        MOVE(tp, unEx(trans_exp e1));
        MOVE(ti, unEx(trans_exp e2));
        CJUMP(JZ, tp, nullExp, lnull, lnotnull);
        LABEL(lnull);
        MOVE(tp, nullExp);
        JUMP(lend);
        LABEL(lnotnull);
        copyptr tp tp;
        MOVE(mem_of(BINOP(A.PLUS, tp, intConst 4)),
             BINOP(A.MINUS, mem_of(BINOP(A.PLUS, tp, intConst 4)), ti)
            );
        LABEL(lend)
      ], tp))
    end

  | A.BinOpExp(e1,op,e2,_,_) -> (
      match op with
      | A.RELLT | A.RELLE | A.RELGT | A.RELGE | A.RELEQ | A.RELNE -> (
          Cx(function (lt,lf) -> IR.CJUMP(IR.rel2jmp op,
                                         unEx(trans_exp e1),
                                         unEx(trans_exp e2),
                                         lt, lf))
        )
      | A.LOGAND -> Cx(function (lt, lf) -> (
          let lx = simpLabel() in
          seq_of [
                  unCx(trans_exp e1)(lx, lf);
                  LABEL(lx);
                  unCx(trans_exp e2)(lt, lf)
          ]
        ))
      | A.LOGOR -> Cx(function (lt, lf) -> (
          let lx = simpLabel() in
          seq_of [
                  unCx(trans_exp e1)(lt, lx);
                  LABEL(lx);
                  unCx(trans_exp e2)(lt, lf)
          ]
        ))
      | A.LOGXOR -> Cx(function (lt, lf) -> (
          let t = TP.simpTemp() in
          let lx = simpLabel() in
          let ly = simpLabel() in
          seq_of [
            MOVE(TEMP t, unEx(trans_exp e1));
            CJUMP(JNZ, TEMP t, intConst 0, lx, ly);
            LABEL(lx);
            unCx(trans_exp e2)(lt, lf);
            LABEL(ly);
            unCx(trans_exp e2)(lt, lf)
          ]
        ))
      | A.PTREQ -> Cx(function (lt, lf) -> (
          let tp = TP.simpTemp() in
          let tq = TP.simpTemp() in
          let lx = simpLabel() in
          let ly = simpLabel() in
          seq_of [
            MOVE(TEMP tp, unEx(trans_exp e1));
            MOVE(TEMP tq, unEx(trans_exp e2));
            CJUMP(JZ, TEMP tp, TEMP tq, lt, lx);
            LABEL(lx);
            CJUMP(JZ, mem_of(TEMP tp), mem_of(TEMP tq), ly, lf);
            LABEL(ly);
            CJUMP(JZ, mem_of(BINOP(A.PLUS, TEMP tp, intConst 4)), 
                      mem_of(BINOP(A.PLUS, TEMP tq, intConst 4)),
                      lt, lf)
          ]
        ))
      | A.PTRNE -> Cx(function (lt, lf) -> (
          let tp = TP.simpTemp() in
          let tq = TP.simpTemp() in
          let lx = simpLabel() in
          let ly = simpLabel() in
          seq_of [
            MOVE(TEMP tp, unEx(trans_exp e1));
            MOVE(TEMP tq, unEx(trans_exp e2));
            CJUMP(JZ, TEMP tp, TEMP tq, lf, lx);
            LABEL(lx);
            CJUMP(JZ, mem_of(TEMP tp), mem_of(TEMP tq), ly, lt);
            LABEL(ly);
            CJUMP(JZ, mem_of(BINOP(A.PLUS, TEMP tp, intConst 4)), 
                      mem_of(BINOP(A.PLUS, TEMP tq, intConst 4)),
                      lf, lt)
          ]
        ))
      | A.DIVIDE ->
          let t1 = TEMP(TP.simpTemp()) in
          let t2 = TEMP(TP.simpTemp()) in
          let lz = simpLabel() in
          let lnz = simpLabel() in
          Ex(ESEQ(seq_of [
            MOVE(t1, unEx(trans_exp e1));
            MOVE(t2, unEx(trans_exp e2));
            CJUMP(JZ, t2, intConst 0, lz, lnz);
            LABEL(lz);
            EXP(CALLOP("_l2_error",
                   [NAME ".Lfilename"; intConst 0; NAME ".Ldvz"]));
            LABEL(lnz)
          ]
        , BINOP(A.DIVIDE, t1, t2)))
      | A.MOD ->
          let t1 = TEMP(TP.simpTemp()) in
          let t2 = TEMP(TP.simpTemp()) in
          let lz = simpLabel() in
          let lnz = simpLabel() in
          Ex(ESEQ(seq_of [
            MOVE(t1, unEx(trans_exp e1));
            MOVE(t2, unEx(trans_exp e2));
            CJUMP(JZ, t2, intConst 0, lz, lnz);
            LABEL(lz);
            EXP(CALLOP("_l2_error",
                   [NAME ".Lfilename"; intConst 0; NAME ".Ldmz"]));
            LABEL(lnz)
          ]
        , BINOP(A.MOD, t1, t2)))
      | _ -> Ex(BINOP(op, unEx(trans_exp e1), unEx(trans_exp e2)))
    )
  | A.AmpersandExp(A.UnOpExp(A.DEREF,e,_,_),_,_) ->
      trans_exp e
  | A.AmpersandExp(lv,_,_) -> (
      let tnew = TEMP(TP.simpTemp()) in
      Ex(ESEQ(IR.seq_of [
        newptr(tnew);
        LEA(mem_of(tnew), unEx(trans_exp lv));
        MOVE(mem_of(BINOP(A.PLUS, tnew, intConst 4)), intConst 0);
        MOVE(mem_of(BINOP(A.PLUS, tnew, intConst 8)), intConst 1)
      ], tnew))
    )
  | A.AllocExp(e,tv,_,_) -> (
        let tnew = TEMP(TP.simpTemp())
        and tsize = TEMP(TP.simpTemp())
        and t4size = TEMP(TP.simpTemp())
        and tbase = TEMP(TP.simpTemp())
        and tcount = TEMP(TP.simpTemp())
        and ltop = simpLabel()
        and lnext = simpLabel()
        and lend = simpLabel() in
        let getmem = [
          MOVE(tsize, unEx(trans_exp e));
          MOVE(t4size, BINOP(A.TIMES, tsize, intConst 4));
          MOVE(tnew, CALLOP("_alloc",
                            [BINOP(A.PLUS, t4size, intConst 12)]));
          MOVE(mem_of(BINOP(A.PLUS, tnew, intConst 8)), tsize);
          MOVE(mem_of tnew, BINOP(A.PLUS, tnew, intConst 12));
          MOVE(mem_of(BINOP(A.PLUS, tnew, intConst 4)), intConst 0)
        ]
        and initmem = [
          MOVE(tbase, mem_of tnew);
          MOVE(tcount, t4size);
          LABEL ltop;
          CJUMP(JLE, tcount, intConst 0, lend, lnext);
          LABEL lnext;
          MOVE(tcount, BINOP(A.MINUS, tcount, intConst 4));
          init_ir(mem_of(BINOP(A.PLUS, tbase, tcount)), tv);
          JUMP ltop;
          LABEL lend
        ]
        in Ex(ESEQ(IR.seq_of(getmem @ initmem), tnew))
      )
  | A.FieldExp(e,id,o,_,_) ->
      Ex(mem_of(BINOP(A.PLUS, unEx(trans_exp e), intConst (4*o.A.ofs))))

  | A.VarLval _ -> raise (TranslateError "munch_exp VarLval")
  | A.DerefLval _ -> raise (TranslateError "munch_exp DerefLval")
  | A.FieldLval _ -> raise (TranslateError "munch_exp FieldLval")
in

(*************************************************************************)
(* Translate Statements *)
(*************************************************************************)

let rec trans_stmts = function
  | [] -> NOTHING
  | [s] -> unNx(trans_stmt s)
  | head :: tail -> SEQ(unNx(trans_stmt head), trans_stmts tail)

and trans_stmt = function
  | A.Assign(lv, e, true, pos) -> (
      match e with
      | A.VarExp _ | A.FieldExp _ -> (
          (*
             This is an assignment |x = y;| where both |x| and |y| are of
             pointer type.  This means we need to make a deep copy of the
             pointer |y| and point |x| to it.
          *)
          let lnull = simpLabel()
          and lnotnull = simpLabel()
          and lend = simpLabel()
          and t1 = TEMP(TP.simpTemp())
          and t2 = TEMP(TP.simpTemp()) in
          Nx(seq_of [
            MOVE(t1, unEx(trans_exp e));
            CJUMP(JZ, t1, nullExp, lnull, lnotnull);
            LABEL(lnull);
            MOVE(unEx(trans_exp lv), nullExp);
            JUMP(lend);
            LABEL(lnotnull);
            MOVE(t2, CALLOP("_alloc", [intConst 12]));
            MOVE(mem_of(t2), mem_of(t1));
            MOVE(mem_of(BINOP(A.PLUS, t2, CONST(Int32.of_int 4))),
                 mem_of(BINOP(A.PLUS, t1, CONST(Int32.of_int 4))));
            MOVE(mem_of(BINOP(A.PLUS, t2, CONST(Int32.of_int 8))),
                 mem_of(BINOP(A.PLUS, t1, CONST(Int32.of_int 8))));
            MOVE(unEx(trans_exp lv), t2);
            LABEL(lend)
          ])
        )
      | _ -> (
          (*
             This is an assignment |x = y;| where both |x| and |y| are of
             pointer type, but |y| is definitely already copied.  This
             means we do /not/ need to make a deep copy of |y| first.
          *)
          Nx(MOVE(unEx(trans_exp lv), unEx(trans_exp e)))
        )
    )
  | A.Assign(lv, e, false, pos) ->
      Nx(MOVE(unEx(trans_exp lv), unEx(trans_exp e)))
  | A.Exp(e) ->
      Nx(unNx(trans_exp e))
  | A.Return(e,pos) ->
      Nx(RETURN(unEx(trans_exp e)))
  | A.IfElse(e, sli1, sli2, _) -> (
      let lt = simpLabel()
      and lf = simpLabel()
      and lend = simpLabel() in
      Nx(seq_of [
        unCx(trans_exp e)(lt, lf);
        LABEL(lt);
        trans_stmts sli1;
        JUMP(lend);
        LABEL(lf);
        trans_stmts sli2;
        LABEL(lend)
      ])
    )


(*************************************************************************)
(* Translate a Program *)
(*************************************************************************)

  and init_var (A.Vardcl(id, tv, pos)) = (
    init_ir(Frame.localIR id, tv)
  )
  in SEQ(
    seq_of(List.map init_var dli),
    trans_stmts sli
  )
)