(**********************************************************************)
(* (c) Greg Morrisett, Neal Glew, Richard Samuels                     *)
(*     September 1998, all rights reserved.                           *)
(**********************************************************************)

(* Talasmx86
 * x86 TAL assembler, generic stuff is in Talasm
 *)
   
open Identifier;;
open Tal;;
open Objfile;;
   
(* needs Stringchan, but does not open *)

(***** asm_env *****)

(* NG: This really belongs somewhere else but the dependancies are all
 *     screwed up, so for now, it it here.
 *)

(* asm_env
 * A structure containing the variables needed to assemble instructions. 
 * This is used by asm.ml and SHOULD NOT CHANGE between implementations.
 *)

type asm_env = {
   a_schan : Stringchan.string_chan;  (* The output channel. *)
   a_symdict : symbol_dict;	      (* The symbol dictionary. *)
   a_secnum : int;		      (* The number of the section. *)
   mutable a_pos_offset : int;	      (* How real pos differs from expected.*)
   mutable a_r_reloclist : relocation list ref  (* Relocations are put here. *)
 }
;;

(***** x86 Specific Functions *****)

(***** Types *****)

(* operand_record: a record specifying a register and a regMem operand. 
   Produced by sort_operands. *)
type operand_record = {
    op_direction : int;		(* The value of the direction flag. *)
    op_regOp : reg;			(* The register operand. *)
    op_regMemOp : genop		(* The memory or 2nd register
				   operand.*)
  }
;;

(***** Macros *****)
   
let bexn_macro (reg, exntag, labl_coerce) =
   [  (Cmp ((Prjr ((reg, []), 0)), exntag));
      (Jcc (NotEq, labl_coerce)) ]

and btagi_macro (reg, tag, labl_coerce, cond) =
   [  (Cmp ((Reg reg), (Immed tag)));
      (Jcc (cond, labl_coerce)) ]

and btagvar_macro (reg, offset, tag, labl_coerce, cond) = 
   [  (Cmp ((Prjr ((reg, []), offset)), (Immed tag)));
      (Jcc (cond, labl_coerce)) ]

and coerce_macro (reg_coerce) = []
and comment_macro (str) = []
and fallthru_macro (conlist)= []

and malloc_macro (size, mallocarg) =
   [  (Push (Immed size, []));
      (Call (Addr gc_malloc_label, []));
      (ArithBin (Add, Reg Esp,Immed 4));
      (Test (Reg Eax, Reg Eax));
      (Jcc (Eq, (out_of_memory_error_label, [])))  ]

and unpack_macro (var, dstreg, varval_coerce) =
   [  (Mov (Reg dstreg, varval_coerce))  ]


and array_bounds_check_macro sizeop indexreg = 
   [  (Cmp ((Reg indexreg), sizeop));
      (Jcc (AboveEq, (array_bounds_error_label, [])))  ]

;;

(********************** INSTRUCTION LENGTHS (PREPARSE) **********************)

(***** Immediate value lengths *****)

(* immed_is_unsigned_byte
   Returns TRUE if a value is an unsigned byte, in 0..255. *)
let immed_is_unsigned_byte n =
   ((n >= 0) && (n <= 255))
;;

(* immed_is_signed_byte
   Returns TRUE if a value is a signed byte, in -128..127. *)
let immed_is_signed_byte n =
   ((n >= (-128)) && (n <= 127))
;;

(* immed_is_byte
   Returns TRUE if a value that can be signed or unsigned is a byte.
   -128..127 is a signed byte; 0..255 is an unsigned byte, so a signed
   or unsigned byte is in -128..255. *)

let immed_is_byte n =
   ((n >= (-128)) && (n <= 255))
;;

(* immed_is_word
   Returns TRUE if the value is not a byte. *)

let immed_is_word n = (not (immed_is_byte n));;

(* immed_len 
   Returns the number of bytes in an immediate value that can be 
   signed or unsigned. *)

let immed_len i =
   if (immed_is_byte i) then 1 else 4
;;

(* immed_len_0 i
   Same as immed_len i, but returns 0 if i is 0. *)

let immed_len_0 i =
   if (i = 0) then 0 else (immed_len i)
;;

(* value_of_immed
   Returns the value of an Immed or a Tag. *)

let value_of_immed immed_or_tag = 
   match immed_or_tag with
      Immed x -> x
    | Tag x -> x
    | _ -> failwith "value_of_immed: bad arg used."
;;

(***** Instruction lengths *****)

(*** Individual instructions ***)

let length_of_mov_array = 4;;

(* length_of_operand : genop -> int
   Returns the length of any general operand.
   If the operand involves a relocation table entry, !numrelocs is incremented. *)

let length_of_operand operand =
   match operand with
      (Reg r) -> 0			(* Registers are already dealt with. *)
    | (Immed i) -> (immed_len i)	(* Immediates are 8 or 32 bits. *)
    | (Tag t) -> (immed_len t)		(* Tags are the same as immediates. *)
    | (Addr a) -> 4			(* Address is max. 4 bytes. *)
    | (Prjl ((l, _), disp)) -> 4	(* Prjl labels are 4 bytes. *)

    | (Prjr ((Esp, _), disp)) ->	(* Prjr Esp requires a SIB. *)
	 1 + (immed_len_0 disp)
    | (Prjr ((Ebp, _), disp)) ->	(* Prjr Ebp can't use 0-byte disp. *)
	 (immed_len disp)
    | (Prjr ((r, _), disp)) ->		(* Prjr's are 0, 8 or 32 bits. *)
	 (immed_len_0 disp)
;;

(* length_of_macro : instruction list -> int
   Returns the summed length of all instructions in the macro. *)

let rec length_of_macro macro_instrs = 
   match macro_instrs with
      [] -> 0
    | (instr :: tail) -> 
	 (length_of_instr instr) + (length_of_macro tail)

(* length_of_instr : instruction -> int
   Returns the instruction's maximum length.

   Always remember to add 1 byte for the opcode and 1 byte 
   for the mod;reg;r/m byte. *)

and length_of_instr instr =
   match instr with
      ArithBin (operation, op1, op2) ->
	 2 + (length_of_operand op1) + (length_of_operand op2)
	    
    | ArithMD (operation, src) ->
	 2 + (length_of_operand src)
    | ArithSR (operation, src, None) ->
	 2 + (length_of_operand src)
    | ArithSR (operation, src, Some immed) ->
	 2 + (length_of_operand src) + 1

    | ArithUn (Dec, (Reg regop)) ->
	 1
    | ArithUn (Inc, (Reg regop)) ->
	 1
    | ArithUn (operation, op) ->
	 2 + (length_of_operand op)

    | Bswap (reg) ->
	 2

    | Call ((Addr a), _) ->
	 1 + (length_of_operand (Addr a))
    | Call (op, _) ->
	 2 + (length_of_operand op)

    | Clc -> 1
    | Cmc -> 1

    | Cmovcc (cond, regdst, (src, [])) ->
	 3 + (length_of_operand src)

    | Cmp (op1, op2) -> 
	 2 + (length_of_operand op1) + (length_of_operand op2)

    | Conv (Movsx (dstreg, dstscale, srcop, srcscale)) ->
	 3 + (length_of_operand srcop)
    | Conv (Movzx (dstreg, dstscale, srcop, srcscale)) ->
	 3 + (length_of_operand srcop)
    | Conv conv ->
	 1

    | Imul3 (dstreg, srcop, immedop) ->
	 2 + (length_of_operand srcop) + (immed_len immedop)

    | Int (intnum) -> 2
    | Into -> 1

    | Jcc (cond, (labl, _)) ->
	 2 + (length_of_operand (Addr labl))

    | Jecxz (labl, _) -> 2
	    
    | Jmp ((Addr labl), _) ->
	 1 + (length_of_operand (Addr labl))
    | Jmp (op, _) ->
	 2 + (length_of_operand op)

    | Lahf -> 1

    | Lea (dstReg, memsrc) ->
	 2 + (length_of_operand memsrc)
	    
    | Loopd ((labl, _), _) -> 2

    | Mov (Reg dstreg, ((Immed _ | Tag _), _)) ->
	 1 + 4
    | Mov (dstOp, ((Immed _ | Tag _), _)) ->
	 2 + (length_of_operand dstOp) + 4
    | Mov (op1, (op2, _)) ->
	 2 + (length_of_operand op1) + (length_of_operand op2)
	    
    | Nop -> 1

    | Pop (Reg reg) -> 1
    | Pop (op) ->
	 2 + (length_of_operand op)

    | Popad -> 1
    | Popfd -> 1

    | Push ((Reg reg), _) -> 1
    | Push ((Immed _ | Tag _) as immedtag, _) -> 
	 let immed = (value_of_immed immedtag) in
	 1 + (immed_len immed)
    | Push ((Addr addr), _) ->
	 5
    | Push (op, _) ->
	 2 + (length_of_operand op)

    | Pushad -> 1
    | Pushfd -> 1
    | Retn (None | (Some 0)) -> 1
    | Retn (Some stuff) -> 3
    | Sahf -> 1
    | Setcc (cond, op) ->
	 3 + (length_of_operand op)

    | Shld (op, reg, None) -> 
	 3 + (length_of_operand op)
    | Shld (op, reg, (Some _)) ->
	 3 + (length_of_operand op) + 1
    | Shrd (op, reg, None) -> 
	 3 + (length_of_operand op)
    | Shrd (op, reg, (Some _)) ->
	 3 + (length_of_operand op) + 1
	 
    | Stc -> 1

    | Test (op1, op2) ->
	 2 + (length_of_operand op1) + (length_of_operand op2)

    | Xchg (regmemop, regop) ->
	 2 + (length_of_operand regmemop)


(***** Macros *****)
    | Asub (dstreg, arrayop, eltsize, indexreg, sizeop) ->
	 (length_of_macro (array_bounds_check_macro sizeop indexreg))
	    + (length_of_mov_array)
    | Aupd (arrayop, eltsize, indexreg, srcreg, sizeop) ->
	 (length_of_macro (array_bounds_check_macro sizeop indexreg))
	    + (length_of_mov_array)
    | Bexn (reg, exntag, labl_coerce) ->
	 (length_of_macro (bexn_macro (reg, exntag, labl_coerce)))
    | Btagi (reg, tag, labl_coerce, cond) ->
	 (length_of_macro (btagi_macro (reg, tag, labl_coerce, cond)))
    | Btagvar (reg, offset, tag, labl_coerce, cond) ->
	 (length_of_macro
	    (btagvar_macro (reg, offset, tag, labl_coerce, cond)))
    | Coerce reg_coerce ->
	 (length_of_macro (coerce_macro reg_coerce))
    | Comment str ->
	 (length_of_macro (comment_macro str))
    | Fallthru conlist ->
	 (length_of_macro (fallthru_macro conlist))
    | Malloc (size, mallocarg) ->  (* put in an arbitrary label *)
	 (length_of_macro (malloc_macro (size, mallocarg)))
    | Unpack (var, dstreg, (Reg varreg, _)) when dstreg = varreg ->
	 0
    | Unpack (var, dstreg, varval_coerce) ->
	 (length_of_macro (unpack_macro (var, dstreg, varval_coerce)))

    | _ -> (invalid_arg "length_of_instr: Unknown instruction or bad operands")
;;

(***** Data length *****)

let length_of_data_item ditem =
   match ditem with
    | Dlabel (_, _) -> 4
    | Dtag (_) -> 4
    | Dbytes (str) -> (String.length str)
    | D2bytes (_) -> 2
    | D4bytes (_) -> 4
    | Djunk -> 4
    | Dexnname (_) -> 4
    | Dup -> 0
    | Ddown -> 0
;;

(********************* INSTRUCTION ENCODING (ASSEMBLY) **********************)

(***** Registers *****)

let encode_register = function
 | Eax -> 0x0
 | Ecx -> 0x1
 | Edx -> 0x2
 | Ebx -> 0x3
 | Esp -> 0x4
 | Ebp -> 0x5
 | Esi -> 0x6
 | Edi -> 0x7
 | _ -> (failwith "encode_register: invalid register code")
;;

let encode_condition cond = 
   match cond with
      Above ->      0x7
    | AboveEq ->    0x3
    | Below ->      0x2
    | BelowEq ->    0x6
    | Eq ->         0x4
    | Greater ->    0xF
    | GreaterEq ->  0xD
    | Less ->       0xC
    | LessEq ->     0xE
    | NotEq ->      0x5
    | NotOverflow-> 0x1
    | NotSign ->    0x9
    | Overflow ->   0x0
    | ParityEven -> 0xA
    | ParityOdd ->  0xB
    | Sign ->       0x8
;;

let encode_arith_bin_opcode = function
   Adc -> 0x2
 | Add -> 0x0
 | And -> 0x4
 | Or ->  0x1
 | Sbb -> 0x3
 | Sub -> 0x5
 | Xor -> 0x6
 | _ -> failwith "encode_arith_bin_opcode: Imul2 was used."
;;

let encode_arith_md_subopcode = function
   Div -> 0x6
 | Idiv -> 0x7
 | Imul1 -> 0x5
 | Mul -> 0x4
;;

let encode_arith_sr_subopcode = function
   Rol -> 0x0
 | Ror -> 0x1
 | Rcl -> 0x2
 | Rcr -> 0x3
 | Shl -> 0x4
 | Sal -> 0x4
 | Shr -> 0x5
 | Sar -> 0x7
;;

let encode_arith_un_opcode = function
   Dec -> 0xFE
 | Inc -> 0xFE
 | Neg -> 0xF6
 | Not -> 0xF6
;;

let encode_arith_un_subopcode = function
   Dec -> 0x1
 | Inc -> 0x0
 | Neg -> 0x3
 | Not -> 0x2
;;

let encode_conv = function
   Cbw -> 0x98
 | Cdq -> 0x99
 | Cwd -> 0x99
 | Cwde -> 0x98
 | _ -> failwith "encode_conv: unknown code."
;;

let encode_scale = function
   Byte1 -> 0x0
 | Byte2 -> 0x1
 | Byte4 -> 0x2
 | Byte8 -> 0x3
;;

let encode_eltsize = function
   1 -> 0x0
 | 2 -> 0x1
 | 4 -> 0x2
 | 8 -> 0x3
 | _ -> invalid_arg "Talasmx86.encode_eltsize"
;;

(***** Flags and such *****)

let sign_extend_flag = function
   true -> 0x2
 | false -> 0x0
;;

let word_flag = function
   true -> 0x1
 | false -> 0x0
;;

(* Use the sign-extend bit to indicate 8-bit immediate values. *)
let sign_extend_immed n =
   (sign_extend_flag (immed_is_signed_byte n))
;;

(***** Writing *****)

let write_byte env n = 
   (Stringchan.put_byte env.a_schan n)
;;

let write_2bytes env n = 
   (Stringchan.put_2bytes env.a_schan n)
;;

let write_4bytes env n = 
   (Stringchan.put_4bytes env.a_schan n)
;;

(* write_immed env immed
   Writes an immediate value as an 8-bit or 32-bit value. *)

let write_immed env immed =
   if (immed_is_signed_byte immed) then
      (write_byte env immed)
   else
      (write_4bytes env immed)
;;

(* write_immed_0 env immed
   Same, but doesn't write if immed is 0. *)

let write_immed_0 env immed =
   if (immed <> 0) then 
      (write_immed env immed)
;;

(***** Labels & Relocations *****)

(* add_reloc
   Side effects: Inserts a new relocation entry into the relocation table. *)
let add_reloc env rel scale ident addend public =
   try
      let reloc = (make_reloc (Stringchan.get_mark env.a_schan) rel scale
		 	(lookup_symbol env.a_symdict ident) addend public) in
      (env.a_r_reloclist := reloc :: !(env.a_r_reloclist))
   with
      Dict.Absent -> 
	 (invalid_arg ("label '" ^ (id_to_string ident) ^ "' absent"))
;;

(* write_label_addend
   Side effects: Writes a placeholder and creates a relocation in r_reloclist
     to label labl, with relativity rel and the given addend.*)
let write_label_addend env rel labl addend =
   (add_reloc env rel Byte4 labl addend false);
   (write_4bytes env 0)
;;

(* write_label
   Side effects: Writes a label with a 0 addend and creates a relocation. *)
let write_label env rel labl =
   (write_label_addend env rel labl 0)
;;


(* write_8bit_label
   Side effects: Writes an 8-bit label with a 0 addend and creates an
   internal relocation. *)
let write_8bit_label env labl =
   (add_reloc env Relative Byte1 labl 0 false);
   (write_byte env 0)
;;

(* write_public_label_addend
   Side effects: writes a label and forces it to be public. *)
let write_public_label_addend env rel labl addend = 
   (add_reloc env rel Byte4 labl addend true);
   (write_4bytes env 0)
;;

(* label_is_close
   Returns TRUE if the label can be jumped to with an 8-bit jump; i.e.,
   if the label is in the current section and within 127 bytes of the current
   location. *)
let label_is_close env labl =
   try
      let current_pos = 2 + (Stringchan.get_mark env.a_schan) in
      let sym = (lookup_symbol env.a_symdict labl) in
      if (sym.sym_section = env.a_secnum) then
	 (if (sym.sym_offset <= current_pos) then 
	    ((current_pos - sym.sym_offset) < 128)
	 else
	    (((sym.sym_offset - env.a_pos_offset) - current_pos) <= 130) )
      else false
   with
      Dict.Absent -> false
;;

(***** Operand writing *****)

(* sort_operands (operand1, operand2)
   Returns an operand_record specifying which direction the operation is in,
   and which are the memory and register operands. *)

let reg_to_reg = 0x2
and reg_to_mem = 0x0
and mem_to_reg = 0x2
;;

let sort_operands = function
   (Reg regOp1, Reg regOp2) -> 
      {op_direction=reg_to_reg; op_regOp=regOp1; op_regMemOp=(Reg regOp2)}
 | (Reg regOp1, memOp2) ->
      {op_direction = mem_to_reg; op_regOp = regOp1; op_regMemOp = memOp2}
 | (memOp1, Reg regOp2) ->
      {op_direction = reg_to_mem; op_regOp = regOp2; op_regMemOp = memOp1}
 | (memOp1, memOp2) -> failwith "sort_operands: two memory operands."
;;

(* modregrm mod reg rm
   Encodes a mod;reg;r/m byte given the three arguments. *)

let modregrm modv reg rm =
   ((modv lsl 6) lor (reg lsl 3) lor rm)
;;

(* sib scale ind base 
   Encodes a sib byte. Its format is the same as the mod;reg;r/m byte. *)

let sib = modregrm;;

(* write_regmem_operand env regOperand regmemop
   Combines the previously determined regOperand with the mod;;r/m values
   for the register/memory operand, then writes the mod;reg;r/m field
   and the operand's displacement, if relevant. 

   If any labels are used in this instruction, an entry is made for them
   in the relocation table. *)

let write_regmem_operand env regOperand regmemop =
   match regmemop with
					(* Second register operand *)
      Reg regOp2 ->
	 (write_byte env (modregrm  0x3 regOperand (encode_register regOp2)))

					(* Indirect memory operand *)
    | Prjr ((baseReg, _), disp) ->
	 let modValue =
	    if (disp = 0  &&  baseReg <> Ebp) then 0x0
	    else if (immed_is_byte disp) then 0x1
	    else 0x2 in
	 (write_byte env (modregrm  modValue regOperand
			       (encode_register baseReg)));
	 if baseReg = Esp then		(* Need SIB for writing Esp as base *)
	    (write_byte env (sib  0x0 (encode_register Esp)
				  (encode_register Esp)));
	 if baseReg = Ebp then
	    (write_immed env disp)	(* 0 offset with Ebp: extra byte *)
	 else
	    (write_immed_0 env disp)

					(* Direct memory operand + offset *)
    | Prjl ((labl, _), disp) ->
	 (write_byte env (modregrm  0x0 regOperand 0x5));
	 (write_label_addend env Absolute labl disp);
	 
    | Addr labl ->
	 invalid_arg "write_regmem_operand: used Addr."
    | Tag int ->
	 invalid_arg "write_regmem_operand: used Tag."
    | Immed int ->
	 invalid_arg "write_regmem_operand: used Immed."
;;
	    
(* write_operands env (operands: operand_record)
   Writes the register operand and the regmem operand
   from the data structure. *)
	    
let write_operands env operands =
   (write_regmem_operand env (encode_register operands.op_regOp) 
	 operands.op_regMemOp)
;;

(***** Individual instructions *****)
      
let write_shift_double_instr env opcode operand reg shiftamt = 
   begin
      (write_byte env 0x0F);
      (write_byte env opcode);
      (write_regmem_operand env (encode_register reg) operand);
      if (shiftamt != (-1)) then
	 (write_byte env shiftamt);
   end
;;

(* write_mov_array
   Writes a mov instruction to or from an array based in a register. 
   Offset in array is [arrayreg + scale*index + offset]*)

let write_mov_array env direction eltsize srcdstreg arrayreg indexreg offset =
   begin
      (write_byte env ((0x88 lor direction) lor (word_flag true)));
      (write_byte env (modregrm 0x1 (encode_register srcdstreg) offset));
      (write_byte env (sib (encode_eltsize eltsize) (encode_register indexreg)
			    (encode_register arrayreg)));
      (write_byte env 0x4)		
   end
;;

let decode_array_op genop =
  match genop with
    Prjr ((r,_),offset) -> (r,offset)
  | Prjl ((l,_),offset) ->
      failwith "Talasmx86.decode_array_op - array ops on labels unimplemented"
  | _ -> invalid_arg "Talasmx86.decode_array_op"
;;

(* write_array_bounds_check
   Writes a check that jumps to an error label if the array index is
   out of bounds. *)

let rec write_array_bounds_check env arrayreg indexreg =
   (write_macro env (array_bounds_check_macro arrayreg indexreg))

(* write_macro
   Writes a list of instructions as a macro. *)

and write_macro env instrs = 
   (List.iter (write_instr env) instrs);
      
(***** Write_instr *****)

(* write_instr env instr
   Writes the entire instruction to the buffer. *)

and write_instr env instr =
   match instr with

      ArithBin (Imul2, (Reg regop), ((Immed _ | Tag _) as immedtag)) -> 
	 (* Imul2 reg, immed is the same as Imul3 reg, reg, immed *)
	 let immed = (value_of_immed immedtag) in
	 (write_byte env (0x69 lor (sign_extend_immed immed)));
	 (write_regmem_operand env (encode_register regop) (Reg regop));
	 (write_immed env immed);

    | ArithBin (Imul2, (Reg dstreg), srcop) ->
	 (write_byte env 0x0F);
	 (write_byte env 0xAF);
	 (write_regmem_operand env (encode_register dstreg) srcop);

    | ArithBin (operation, op1, ((Immed _ | Tag _) as immedtag)) ->
	 let immed = (value_of_immed immedtag) in
	 (write_byte env (0x80 lor (sign_extend_immed immed)
			       lor (word_flag true)));
	 (write_regmem_operand env (encode_arith_bin_opcode operation) op1);
	 (write_immed env immed);

    | ArithBin (operation, op1, op2) ->
	 let operands = (sort_operands (op1, op2)) in
	 (write_byte env (((encode_arith_bin_opcode operation) lsl 3)
       		          lor (operands.op_direction
                          lor  (word_flag true))));
	 (write_operands env operands);


    | ArithMD (operation, src) ->
	 (* Multiply / divide EAX by src, and put result or quotient/remainder
            in EAX/EDX. *)
	 (write_byte env (0xF6 lor (word_flag true)));
	 (write_regmem_operand env (encode_arith_md_subopcode operation) src); 

    | ArithSR (operation, src, None) ->
	 (* Shift/Rotate using ECX as shift amount *)
	 (write_byte env (0xD2 lor (word_flag true)));
	 (write_regmem_operand env (encode_arith_sr_subopcode operation) src);

    | ArithSR (operation, src, (Some immed)) ->
	 (* Shift/Rotate using 8-bit immed as shift amount *)
	 (write_byte env (0xC0 lor (word_flag true)));
	 (write_regmem_operand env (encode_arith_sr_subopcode operation) src);
	 (write_immed env (immed land 0xFF));

    | ArithUn (Dec, (Reg regop)) ->
	 (write_byte env (0x48 lor (encode_register regop)));
    | ArithUn (Inc, (Reg regop)) ->
	 (write_byte env (0x40 lor (encode_register regop)));
    | ArithUn (operation, op) ->
	 (write_byte env ((encode_arith_un_opcode operation) 
			       lor (word_flag true)));
	 (write_regmem_operand env (encode_arith_un_subopcode operation) op);

(* Bswap reg *)
    | Bswap (reg) ->
	 (write_byte env 0x0F);
	 (write_byte env (0xC8 lor (encode_register reg)));

(** Call **)
(* We only use near calls, in the flat memory model. *)

(* Call addr *)
    | Call (Addr labl, _) ->
	 (write_byte env 0xE8);
	 (write_label env Relative labl);

(* Call reg/mem *)
    | Call (op, _) ->
	 (write_byte env 0xFF);
	 (write_regmem_operand env 0x2 op);
	 
    | Clc ->
	 (write_byte env 0xF8);

    | Cmc ->
	 (write_byte env 0xF5);

    | Cmovcc (cond, regdst, (src, [])) ->
	 (* Conditional move regdst<-memsrc or regdst<-regsrc *)
	 (write_byte env 0x0F);
	 (write_byte env (0x40 lor (encode_condition cond)));
	 (write_regmem_operand env (encode_register regdst) src);

    | Cmp (op1, ((Immed _ | Tag _) as immedtag)) ->
	 let immed = (value_of_immed immedtag) in
	 (write_byte env (0x80 lor ((sign_extend_immed immed)
                                          lor (word_flag true))));
	 (write_regmem_operand env 0x7 op1);
	 (write_immed env immed);

    | Cmp (op1, op2) ->
	 let operands = (sort_operands (op1, op2)) in
	 (write_byte env ((0x38 lor (operands.op_direction
       			        lor (word_flag true)))));
	 (write_operands env operands);
	 
    | Conv (Movsx (dstreg, dstscale, srcop, srcscale)) ->
	 (* Move byte or word into dword register, sign-extend *)
	 (* We can ignore the dstscale -- we assume we're expanding into
	    a 32-bit register. *)
	 (write_byte env 0x0F);
	 (write_byte env (0xBE lor (word_flag (srcscale != Byte1))));
	 (write_regmem_operand env (encode_register dstreg) srcop);

    | Conv (Movzx (dstreg, dstscale, srcop, srcscale)) ->
	 (* Move byte or word into dword register, zero-extend *)
	 (* We can ignore the dstscale -- we assume we're expanding into
	    a 32-bit register. *)
	 (write_byte env 0x0F);
	 (write_byte env (0xB6 lor (word_flag (srcscale != Byte1))));
	 (write_regmem_operand env (encode_register dstreg) srcop);

    | Conv (conv) ->
	 (write_byte env (encode_conv conv));

    | Imul3 (dstreg, srcop, immedop) ->
	 (* dstreg <- srcop * immedop *)
	 (write_byte env (0x69 lor (sign_extend_immed immedop)));
	 (write_regmem_operand env (encode_register dstreg) srcop);
	 (write_immed env immedop);

    | Int (intnum) ->
	 (write_byte env 0xCD);
	 (write_byte env intnum);

    | Into ->
	 (write_byte env 0xCE);

    | Jcc (cond, (labl, _)) when (label_is_close env labl) ->
	 (write_byte env (0x70 lor (encode_condition cond)));
	 (write_8bit_label env labl);

    | Jcc (cond, (labl, _)) ->
	 (write_byte env 0x0F);
	 (write_byte env (0x80 lor (encode_condition cond)));
	 (write_label env Relative labl);

    | Jecxz (labl, _) when (label_is_close env labl) ->
	 (write_byte env 0xE3);
	 (write_8bit_label env labl);
    | Jecxz (labl, _) ->
	 invalid_arg "jecxz requires a close label (8-bit offset).";

(* Jmp addr -- See notes on Call. *)
    | Jmp (Addr labl, _) when (label_is_close env labl) ->
	 (write_byte env 0xEB);
	 (write_8bit_label env labl);

    | Jmp (Addr labl, _) ->
	 (write_byte env 0xE9);
	 (write_label env Relative labl);

(* Jmp reg/mem *)
    | Jmp (op, _) ->
	 (write_byte env 0xFF);
	 (write_regmem_operand env 0x4 op);


    | Lahf ->
	 (write_byte env 0x9F);

    | Lea (dstReg, memsrc) ->
	 (write_byte env 0x8D);
	 (write_regmem_operand env (encode_register dstReg) memsrc);
	 (* Note: does not check error cases (memsrc must be a mem operand) *)

				(* ECX--; loop if ECX != 0 *)
    | Loopd ((labl, _), None) when (label_is_close env labl) ->
	 (write_byte env 0xE2);
	 (write_8bit_label env labl);
				(* ECX--; loop if ECX != 0 && Zflag == flag *)
    | Loopd ((labl, _), Some flag) when (label_is_close env labl) ->
	 (write_byte env (0xE0 lor (if flag then 0x01 else 0x0)));
	 (write_8bit_label env labl);


(* Mov reg, immed -- 4-byte simm *)
    | Mov ((Reg dstReg), ((Immed _ | Tag _) as immedtag, _)) ->
	 let immed = (value_of_immed immedtag) in
	 (write_byte env (0xB0 lor
			    (((word_flag true) lsl 3) lor
			       (encode_register dstReg))));
	 (write_4bytes env immed)

(* Mov mem, immed|tag -- 4-byte simm *)
    | Mov (dst, ((Immed _ | Tag _) as immedtag, _)) ->
	 let immed = (value_of_immed immedtag) in 
	 (write_byte env (0xC6 lor (word_flag true)));
	 (write_regmem_operand env 0x0 dst);
	 (write_4bytes env immed);

(* Mov reg, immed_addr *)
    | Mov ((Reg dstReg), ((Addr addr), _)) ->
	 (write_byte env (0xB0 lor
			    (((word_flag true) lsl 3) lor
			       (encode_register dstReg))));
	 (write_public_label_addend env Absolute addr 0);

(* Mov mem, immed_addr *)
    | Mov (dst, ((Addr addr), _)) ->
	 (write_byte env (0xC6 lor (word_flag true)));
	 (write_regmem_operand env 0x0 dst);
	 (write_public_label_addend env Absolute addr 0);

(* Mov reg/mem, reg/mem *)
    | Mov (dst, (src, _)) ->
	 let operands = (sort_operands (dst, src)) in
	 (write_byte env (0x88 lor (operands.op_direction
			       lor (word_flag true))));
	 (write_operands env operands);

    | Nop ->
	 (write_byte env 0x90);

    | Pop (Reg reg) ->
	 (write_byte env (0x58 lor (encode_register reg)));
    | Pop (op) ->
	 (write_byte env 0x8F);
	 (write_regmem_operand env 0x0 op);

    | Popad ->
	 (write_byte env 0x61);

    | Popfd ->
	 (write_byte env 0x9D);

    | Push ((Reg regOp), _) ->
	 (write_byte env (0x50 lor (encode_register regOp)));
    | Push ((Immed _ | Tag _) as immedtag, _) ->
	 let immed = (value_of_immed immedtag) in
	 (write_byte env ((0x68
		  lor (sign_extend_immed immed))));
	 (write_immed env immed)
    | Push ((Addr addr), _) ->
	 (write_byte env 0x68);
	 (write_public_label_addend env Absolute addr 0)	 

    | Push (op, _) ->
	 (write_byte env 0xFF);
	 (write_regmem_operand env 0x6 op);

    | Pushad ->
	 (write_byte env 0x60);

    | Pushfd ->
	 (write_byte env 0x9C);

    | Retn (None | (Some 0)) ->
	 (write_byte env 0xC3);
    | Retn (Some stuff) ->
	 (write_byte env 0xC2);
	 (write_2bytes env stuff);

    | Sahf ->
	 (write_byte env 0x9E);

    | Setcc (cond, op) ->
	 (write_byte env 0x0F);
	 (write_byte env (0x90 lor (encode_condition cond)));
	 (write_regmem_operand env 0x0 op);

    | Shld (op, reg, None) ->
	 (write_shift_double_instr env 0xA5 op reg (-1));
    | Shld (op, reg, (Some shiftamt)) ->
	 (write_shift_double_instr env 0xA4 op reg shiftamt);
    | Shrd (op, reg, None) ->
	 (write_shift_double_instr env 0xAD op reg (-1));
    | Shrd (op, reg, (Some shiftamt)) ->
	 (write_shift_double_instr env 0xAC op reg shiftamt);

    | Stc ->
	 (write_byte env 0xF9);

    | Test (op1, ((Immed _ | Tag _) as immedtag)) ->
	 let immed = (value_of_immed immedtag) in
	 (write_byte env (0xF6 lor (word_flag true)));
	 (write_regmem_operand env 0x0 op1);
	 (write_immed env immed);
    | Test (op1, op2) ->
	 let operands = (sort_operands (op1, op2)) in
	 (write_byte env (0x84 lor (word_flag true)));
	 (write_operands env operands);
	 (* Note: I don't know what to do with Test reg,mem -- 
	    it seems as if it should
	    be reversed. MASM just encodes it as Test mem, reg. See book. *)

    | Xchg (regmemop, regop) ->
	 (write_byte env (0x86 lor (word_flag true)));
	 (write_regmem_operand env (encode_register regop) regmemop);
	 
(***** Macros *****)

	 (* Asub : dstreg <- arrayop[indexreg] *)
    | Asub (dstreg, arrayop, eltsize, indexreg, sizeop) ->
	let (arrayreg,offset) = decode_array_op arrayop in
	write_array_bounds_check env sizeop indexreg;
	write_mov_array env mem_to_reg eltsize dstreg arrayreg indexreg offset

	 (* Aupd : arrayop[indexreg] <- srcreg *)
    | Aupd (arrayop, eltsize, indexreg, srcreg, sizeop) ->
	let (arrayreg,offset) = decode_array_op arrayop in
	write_array_bounds_check env sizeop indexreg;
	write_mov_array env reg_to_mem eltsize srcreg arrayreg indexreg offset

	 (* Bexn : branch to label if r.exname != op *)
    | Bexn (reg, exntag, labl_coerce) ->
	 (write_macro env (bexn_macro (reg, exntag, labl_coerce)));

	 (* Btagi : Compare tag and branch on condition *)
    | Btagi (reg, tag, labl_coerce, cond) ->
	 (write_macro env (btagi_macro (reg, tag, labl_coerce, cond)));

	 (* Btagvar : Compare tag in rec and branch on condition *)
    | Btagvar (reg, offset, tag, labl_coerce, cond) ->
	 (write_macro env
	    (btagvar_macro (reg, offset, tag, labl_coerce, cond)));

	 (* Coerce register : no code value. *)
    | Coerce (reg_coerce) ->
	 (write_macro env (coerce_macro reg_coerce));

	 (* Comment : no code value. *)
    | Comment (str) ->
	 (write_macro env (comment_macro str));

	 (* Fallthru : no code value. Only valid when preceding a label. *)
    | Fallthru (conlist) ->
	 (write_macro env (fallthru_macro conlist));
	 
	 (* Malloc : allocate item of size i into register r *)
    | Malloc (size, mallocarg) ->
	 (write_macro env (malloc_macro (size, mallocarg)));

	 (* Unpack : effectively a move, if registers are different. *)
    | Unpack (var, dstreg, (Reg varreg, _)) when dstreg = varreg ->
	 ();
    | Unpack (var, dstreg, varval_coerce) ->
	 (write_macro env (unpack_macro (var, dstreg, varval_coerce)));

    | _ -> (invalid_arg "write_instr: Unknown instruction or invalid args")
;;

(***** Data encoding *****)

(* write_data_item
   Side effects: 
     - Writes a data item to the environment's schan.
     - Adds relocations to the env's relocation list. *)

let write_data_item env ditem = 
   match ditem with
      Dlabel (labl, _) ->
	 (write_public_label_addend env Absolute labl 0)
    | Dtag (tag, _) ->
	 (write_4bytes env tag)
    | Dbytes (bytes) ->
	 (Stringchan.put_string env.a_schan bytes)
    | D2bytes (bytes) ->
	 (write_2bytes env bytes)
    | D4bytes (bytes) ->
	 (write_4bytes env bytes)
    | Djunk ->
	 (write_4bytes env 0x0000)
    | Dexnname (con) ->
	 (write_4bytes env 0x0000)
    | Dup -> ()
    | Ddown -> ()
;;

(* EOF: talasmx86.ml *)
