(* 
 * 32bit, x86 instruction set.
 *)
architecture X86 = 
struct

  name "X86"

  superscalar

  little endian (* is this right??? *)

  lowercase assembly

    (*
    * Assembly note:
    * Note: we are using the AT&T syntax (for Linux) and not the intel syntax
    * memory operands have the form:
    *       section:disp(base, index, scale)
    * Most of the complication is actually in emiting the correct
    * operand syntax.
    *)

    (* Note: While the x86 has only 8 integer and 8 floating point registers,
     * the SMLNJ compiler fakes it by assuming that it has 32 integer
     * and 32 floating point registers.  That's why we 
     *)

   storage
      GP "r" = 32 cells of 32 bits in cellset called "register"
                assembly as
                    (fn (0,8)  => "%al"
                      | (0,16) => "%ax"
                      | (0,32) => "%eax"
                      | (1,8)  => "%cl"
                      | (1,16) => "%cx"
                      | (1,32) => "%ecx"
                      | (2,8)  => "%dl"
                      | (2,16) => "%dx"
                      | (2,32) => "%edx"
                      | (3,8)  => "%bl"
                      | (3,16) => "%bx"
                      | (3,32) => "%ebx"
                      | (4,16) => "%sp"
                      | (4,32) => "%esp"
                      | (5,16) => "%bp"
                      | (5,32) => "%ebp"
                      | (6,16) => "%si"
                      | (6,32) => "%esi"
                      | (7,16) => "%di"
                      | (7,32) => "%edi"
                      | (r,_) => "%"^Int.toString r
                    )
   |  FP "f" = 32 cells of 80 bits in cellset called "floating point register"
               assembly as (fn (0,_) => "%st"
                             | (f,_) => 
                                if f < 8 then "%st("^Int.toString f^")"
                                else "%f"^Int.toString f 
                                     (* pseudo register *)
                           )
   |  CC "cc" = cells of 32 bits in cellset called "condition code register"
                assembly as "cc"
   |  MEM "m" = cells of 8 bits called "memory"
                assembly as (fn (r,_) => "m"^Int.toString r)
   |  CTRL "ctrl" = cells of 8 bits called "control"
                assembly as (fn (r,_) => "ctrl"^Int.toString r)

   locations
       eax     = $GP[0]
   and ecx     = $GP[1]
   and edx     = $GP[2]
   and ebx     = $GP[3]
   and esp     = $GP[4]
   and ebp     = $GP[5]
   and esi     = $GP[6]
   and edi     = $GP[7]
   and stackptrR = $GP[4]
   and ST(x)   = $FP[x]
   and asmTmpR   = ~1 (* not used *)
   and fasmTmp   = ~1 (* not used *)

   structure RTL =
   struct
   end 

   structure Instruction = struct
 (* An effective address can be any combination of
  *  base + index*scale + disp 
  *   or
  *   B + I*SCALE + DISP
  *
  * where any component is optional. The operand datatype captures
  * all these combinations.
  *
  *  DISP 	    == Immed | ImmedLabel | Const
  *  B		    == Displace{base=B, disp=0}
  *  B+DISP	    == Displace{base=B, disp=DISP}
  *  I*SCALE+DISP   == Indexed{base=NONE, index=I, scale=SCALE, disp=D}
  *  B+I*SCALE+DISP == Indexed{base=SOME B, index=I, scale=SCALE, disp=DISP}
  *
  *  Note1: The index register cannot be EBP.
  *         The disp field must be one of Immed, ImmedLabel,  or Const.
  *)

  (* Note: Relative is only generated after sdi resolution *)
  datatype operand =
     Immed      of Int32.int	   
   | ImmedLabel of LabelExp.labexp 
   | Relative   of int		
   | LabelEA	of LabelExp.labexp 
   | Direct     of $GP		   
   | FDirect    of $FP		   
   | ST         of $FP		   
   | MemReg     of int (* pseudo memory register *)
   | Displace   of {base: $GP, disp:operand, mem:Region.region}
   | Indexed    of {base: $GP option, index: $GP, scale:int, disp:operand,
		    mem:Region.region}

  type addressing_mode = operand
  
  type ea = operand

  datatype cond! = 
      EQ "e" | NE | LT "l" | LE | GT "g" | GE 
    | B  | BE (* below *)   | A  | AE (* above *) 
    | C  | NC (* if carry *)| P  | NP (* if parity *)
    | O  | NO (* overflow *) 

  datatype binaryOp! = 
     ADDL | SUBL | ANDL | ORL | XORL | SHLL | SARL | SHRL | ADCL | SBBL 
   | ADDW | SUBW | ANDW | ORW | XORW | SHLW | SARW | SHRW 
   | ADDB | SUBB | ANDB | ORB | XORB | SHLB | SARB | SHRB

  datatype multDivOp! = UMUL | IDIV | UDIV

  datatype unaryOp! = DECL | INCL | NEGL | NOTL | NOTW | NOTB

  datatype move! = MOVL 
                 | MOVB             
                 | MOVW             
                 | MOVSWL | MOVZWL  (* word -> long *) 
                 | MOVSBL | MOVZBL  (* byte -> long *)

 (* The Intel manual is incorrect on the description of FDIV and FDIVR *)
  datatype fbinOp! = 
      FADDP   | FADDS    
    | FMULP   | FMULS   
              | FCOMS    
              | FCOMPS    
    | FSUBP   | FSUBS  	(* ST(1) := ST-ST(1); [pop] *)
    | FSUBRP  | FSUBRS 	(* ST(1) := ST(1)-ST; [pop] *)
    | FDIVP   | FDIVS   (* ST(1) := ST/ST(1); [pop] *)
    | FDIVRP  | FDIVRS 	(* ST(1) := ST(1)/ST; [pop] *)
              | FADDL  
              | FMULL 
              | FCOML    
              | FCOMPL    
              | FSUBL 	(* ST(1) := ST-ST(1); [pop] *)
              | FSUBRL 	(* ST(1) := ST(1)-ST; [pop] *)
              | FDIVL   (* ST(1) := ST/ST(1); [pop] *)
              | FDIVRL 	(* ST(1) := ST(1)/ST; [pop] *)

  datatype fibinOp! =
      FIADDS | FIMULS   | FICOMS | FICOMPS
    | FISUBS | FISUBRS	| FIDIVS | FIDIVRS 
    | FIADDL | FIMULL   | FICOML | FICOMPL
    | FISUBL | FISUBRL  | FIDIVL | FIDIVRL

  datatype funOp! = FABS | FCHS 
                  | FSIN | FCOS | FTAN 
                  | FSCALE | FRNDINT | FSQRT
	          | FTST | FXAM 
                  | FINCSTP | FDECSTP

  datatype fenvOp! = FLDENV | FNLDENV | FSTENV | FNSTENV

  end (* struct Instruction *)

  (* A bunch of routines for emitting assembly *)
  functor Assembly
     (structure MemRegs : MEMORY_REGISTERS where I = Instr) =
  struct
     val memReg = MemRegs.memReg regmap
     fun emitInt32 i = 
     let val s = Int32.toString i
         val s = if i >= 0 then s else "-"^String.substring(s,1,size s-1)
     in  emit s end
		
     fun emitScale 0 = emit "1"
       | emitScale 1 = emit "2"
       | emitScale 2 = emit "4"
       | emitScale 3 = emit "8"
       | emitScale _ = error "emitScale"

     and eImmed(I.Immed (i)) = emitInt32 i
       | eImmed(I.ImmedLabel lexp) = emit_labexp lexp
       | eImmed _ = error "eImmed"

     and emit_operand opn =
         case opn of
         I.Immed i => (emit "$"; emitInt32 i)
       | I.ImmedLabel lexp => (emit "$"; emit_labexp lexp)
       | I.LabelEA le => emit_labexp le
       | I.Relative _ => error "emit_operand"
       | I.Direct r => emit_GP r
       | I.MemReg r => emit_operand(memReg opn)
       | I.ST f => emit_FP f
       | I.FDirect f => emit_operand(memReg opn)
       | I.Displace{base,disp,mem,...} => 
           (emit_disp disp; emit "("; emit_GP base; emit ")"; 
            emit_region mem)
       | I.Indexed{base,index,scale,disp,mem,...} =>
          (emit_disp disp; emit "("; 
           case base of
             NONE => ()
           | SOME base => emit_GP base;
           comma();
           emit_GP index; comma(); 
           emitScale scale; emit ")"; emit_region mem)

      and emit_disp(I.Immed 0) = ()
        | emit_disp(I.Immed i) = emitInt32 i
        | emit_disp(I.ImmedLabel lexp) = emit_labexp lexp
        | emit_disp _ = error "emit_disp"

     (* The gas assembler does not like the "$" prefix for immediate
      * labels in certain instructions. 
      *)
      fun stupidGas(I.ImmedLabel lexp) = emit_labexp lexp
        | stupidGas(I.LabelEA _) = error "stupidGas"
        | stupidGas opnd = emit_operand opnd

     (* Display the floating point binary opcode *)
      fun isMemOpnd(I.MemReg _) = true
        | isMemOpnd(I.FDirect f) = true
        | isMemOpnd(I.LabelEA _) = true
        | isMemOpnd(I.Displace _) = true
        | isMemOpnd(I.Indexed _) = true
        | isMemOpnd _ = false
      fun chop fbinOp =
          let val n = size fbinOp
          in  case Char.toLower(String.sub(fbinOp,n-1)) of
                (#"s" | #"l") => String.substring(fbinOp,0,n-1)
              | _ => fbinOp
          end

      val emit_dst = emit_operand
      val emit_src = emit_operand
      val emit_opnd = emit_operand
      val emit_rsrc = emit_operand
      val emit_lsrc = emit_operand
      val emit_addr = emit_operand
      val emit_src1 = emit_operand
  end (* Instruction *)

 (* many of these instructions imply certain register usages *)
  instruction 
      NOP
	``nop''

    | JMP of operand * Label.label list
	``jmp\t<stupidGas operand>''

    | JCC of {cond:cond, opnd:operand}
	``j<cond>\t<stupidGas opnd>''

    | CALL of operand * C.cellset * C.cellset * Region.region
	``call\t<stupidGas operand><region><
          emit_defs(cellset1)><
          emit_uses(cellset2)>''

    | LEAVE
	``leave''

    | RET of operand option
	``ret<case operand of NONE => () 
                            | SOME e => (emit "\t"; emit_operand e)>''

   (* integer *)
    | MOVE of {mvOp:move, src:operand, dst:operand}
	``<mvOp>\t<src>, <dst>''

    | LEA of {r32: $GP, addr: operand}
	``leal\t<addr>, <r32>''

    | CMPL of {lsrc: operand, rsrc: operand}
	``cmpl\t<rsrc>, <lsrc>''

    | CMPW of {lsrc: operand, rsrc: operand}
	``cmpb\t<rsrc>, <lsrc>''

    | CMPB of {lsrc: operand, rsrc: operand}
	``cmpb\t<rsrc>, <lsrc>''

    | TESTL of {lsrc: operand, rsrc: operand}
	``testl\t<rsrc>, <lsrc>''

    | TESTW of {lsrc: operand, rsrc: operand}
	``testw\t<rsrc>, <lsrc>''

    | TESTB of {lsrc: operand, rsrc: operand}
	``testb\t<rsrc>, <lsrc>''

    | BINARY of {binOp:binaryOp, src:operand, dst:operand}
	asm: (case (src,binOp) of
               (I.Direct _,
               (I.SARL | I.SHRL | I.SHLL |
                I.SARW | I.SHRW | I.SHLW |
                I.SARB | I.SHRB | I.SHLB)) => ``<binOp>\t%cl, <dst>''
             | _ => ``<binOp>\t<src>, <dst>''
             )

    | MULTDIV of {multDivOp:multDivOp, src:operand}
	``<multDivOp>l\t<src>''

    | MUL3 of {dst: $GP, src2: Int32.int option, src1:operand}
        (* Fermin: constant operand must go first *)
        asm: (case src2 of 
                NONE => ``imul\t<src1>, <dst>''
              | SOME i => ``imul\t$<emitInt32 i>, <src1>, <dst>''
             )

    | UNARY of {unOp:unaryOp, opnd:operand}
	``<unOp>\t<opnd>''

      (* set byte on condition code; note that
       * this only sets the low order byte, so it also
       * uses its operand.
       *)
    | SET of {cond:cond, opnd:operand}
	 ``set<cond>\t<opnd>''

        (* conditional move; Pentium Pro or higher only 
         * Destination must be a register. 
         *)
    | CMOV of {cond:cond, src:operand, dst: $GP} 
	``cmov<cond>\t<src>, <dst>''

    | PUSHL of operand
	``pushl\t<operand>''

    | PUSHW of operand
	``pushw\t<operand>''

    | PUSHB of operand
	``pushb\t<operand>''

    | POP of operand
	``popl\t<operand>''

    | CDQ
	``cdq''

    | INTO
	``into''

   (* parallel copies *)
    | COPY of {dst: $GP list, src: $GP list, tmp:operand option}
	asm: emitInstrs (Shuffle.shuffle{regmap,tmp,dst,src})

    | FCOPY of {dst: $FP list, src: $FP list, tmp:operand option}
	asm: emitInstrs (Shuffle.shufflefp{regmap,tmp,dst,src})

   (* floating *)
    | FBINARY of {binOp:fbinOp, src:operand, dst:operand}
	asm: (if isMemOpnd src then ``<binOp>\t<src>''
              else ``<emit(chop(asm_fbinOp binOp))>\t<src>, <dst>''
             )

    | FIBINARY of {binOp:fibinOp, src:operand}
	asm: ``<binOp>\t<src>'' (* the implied destination is %ST(0) *)

    | FUNARY of funOp
	``<funOp>''

    | FUCOMPP
	``fucompp''

    | FCOMPP
	``fcompp''

    | FXCH of {opnd: $FP}
	asm: (``fxch\t''; if opnd = C.ST(1) then () else ``<opnd>'')

    | FSTPL of operand
	``fstpl\t<operand>''

    | FSTPS of operand
	``fstps\t<operand>''

    | FSTPT of operand
	``fstps\t<operand>''

    | FLD1
	``fld1''

    | FLDL2E
	``fldl2e''

    | FLDL2T
	``fldl2t''

    | FLDLG2
	``fldlg2''

    | FLDLN2
	``fldln2''

    | FLDPI
	``fldpi''

    | FLDZ
	``fldz''

    | FLDL of operand
	``fldl\t<operand>'' 

    | FLDS of operand
	``flds\t<operand>'' 

    | FLDT of operand
	``fldt\t<operand>'' 

    | FILD of operand
	``fild\t<operand>''

    | FILDL of operand
	``fildl\t<operand>''

    | FILDLL of operand
	``fildll\t<operand>''

    | FNSTSW
	``fnstsw''

    | FENV of {fenvOp:fenvOp, opnd:operand} (* load/store environment *)
	``<fenvOp>\t<opnd>''

   (* misc *)
    | SAHF
	``sahf''

   (* annotations *)
    | ANNOTATION of {i:instruction, a:Annotations.annotation}
        asm: (emitInstr i; comment(Annotations.toString a))
end