Initial import of l3c

[snipe.git] / codegen / x86.sml

(* L3 compiler
 * X86 instruction/operand internal representation and manipulation
 * Author: Joshua Wise <jwise@andrew.cmu.edu>
 * Author: Chris Lu <czl@andrew.cmu.edu>
 *)

signature X86 =
sig
  (* register type *)
  datatype reg =
    EAX | EBX | ECX | EDX | ESI | EDI | EBP | RSP | R8D | R9D | R10D | R11D | R12D | R13D | R14D | R15D
  (* operands to instructions *)
  datatype oper = REG of reg | TEMP of Temp.temp | CONST of Word32.word | REL of (reg * int) | STACKARG of int | STR of string
  datatype cc = E | NE | GE | LE | L | G
  datatype size = Byte | Word | Long | Qword
  (* instructions *)
  datatype insn =
    DIRECTIVE of string |
    COMMENT of string |
    LABEL of Label.label |
    SIZE of size * insn |
    MOV of oper * oper |
    SUB of oper * oper |
    IMUL of oper * oper |
    IMUL3 of oper * oper * Word32.word |
    ADD of oper * oper |
    IDIV of oper |
    NEG of oper |
    NOT of oper |
    SAL of oper * oper |
    SAR of oper * oper |
    AND of oper * oper |
    OR of oper * oper |
    XOR of oper * oper |
    CMP of oper * oper |
    TEST of oper * oper |
    SETcc of cc * oper |
    JMP of Label.label |
    Jcc of cc * Label.label |
    CALL of Symbol.symbol * int |
    MOVZB of oper * oper |
    CLTD |
    LIVEIGN of insn |
    RET
  
  structure OperSet : ORD_SET
    where type Key.ord_key = oper;
  structure LiveMap : ORD_MAP
    where type Key.ord_key = int;
  
  val cmpoper : oper * oper -> order
  val opereq : oper * oper -> bool
  val regname : size -> reg -> string
  val regtonum : reg -> int
  val numtoreg : int -> reg
  val ccname : cc -> string
  val opsused : insn list -> OperSet.set
  val prettyprint_oper : size -> oper -> string
  val prettyprint : size -> insn -> string
end

structure x86 :> X86 =
struct


  datatype reg =
    EAX | EBX | ECX | EDX | ESI | EDI | EBP | RSP | R8D | R9D | R10D | R11D | R12D | R13D | R14D | R15D
  datatype oper = REG of reg | TEMP of Temp.temp | CONST of Word32.word | REL of (reg * int) | STACKARG of int | STR of string
  datatype cc = E | NE | GE | LE | L | G
  datatype size = Byte | Word | Long | Qword
  datatype insn =
    DIRECTIVE of string |
    COMMENT of string |
    LABEL of Label.label |
    SIZE of size * insn |
    MOV of oper * oper |
    SUB of oper * oper |
    IMUL of oper * oper |
    IMUL3 of oper * oper * Word32.word |
    ADD of oper * oper |
    IDIV of oper |
    NEG of oper |
    NOT of oper |
    SAL of oper * oper |
    SAR of oper * oper |
    AND of oper * oper |
    OR of oper * oper |
    XOR of oper * oper |
    CMP of oper * oper |
    TEST of oper * oper |
    SETcc of cc * oper |
    JMP of Label.label |
    Jcc of cc * Label.label |
    CALL of Symbol.symbol * int |
    MOVZB of oper * oper |
    CLTD |
    LIVEIGN of insn |
    RET
  
  type func = Ast.ident * insn list

  (* gives name of reg *)
  val regnames =
    [ (EAX, ("al", "ax", "eax", "rax")),
      (EBX, ("bl", "bx", "ebx", "rbx")),
      (ECX, ("cl", "cx", "ecx", "rcx")),
      (EDX, ("dl", "dx", "edx", "rdx")),
      (ESI, ("sil", "si", "esi", "rsi")),
      (EDI, ("dil", "di", "edi", "rdi")),
      (EBP, ("bpl", "bp", "ebp", "rbp")),
      (RSP, ("spl", "sp", "esp", "rsp")),
      (R8D, ("r8b", "r8w", "r8d", "r8")),
      (R9D, ("r9b", "r9w", "r9d", "r9")),
      (R10D, ("r10b", "r10w", "r10d", "r10")),
      (R11D, ("r11b", "r11w", "r11d", "r11")),
      (R12D, ("r12b", "r12w", "r12d", "r12")),
      (R13D, ("r13b", "r13w", "r13d", "r13")),
      (R14D, ("r14b", "r14w", "r14d", "r14")),
      (R15D, ("r15b", "r15w", "r15d", "r15")) ];

  fun regname sz reg =
    let
      val (n, (b, w, l, q)) = valOf (List.find (fn (r, _) => r = reg) regnames)
    in
      case sz
      of Byte => b
       | Word => w
       | Long => l
       | Qword => q
    end

  fun ccname E  = "e"
    | ccname NE = "ne"
    | ccname GE = "ge"
    | ccname LE = "le"
    | ccname G  = "g"
    | ccname L  = "l"

  (* gives number (color) associated with reg *)
  fun regtonum EAX = 0
    | regtonum ESI = 1
    | regtonum EDI = 2
    | regtonum ECX = 3
    | regtonum R8D = 4
    | regtonum R9D = 5
    | regtonum EDX = 6
    | regtonum R10D = 7
    | regtonum R11D = 8
    | regtonum EBX = 9
    | regtonum R12D = 10
    | regtonum R13D = 11
    | regtonum R14D = 12
    | regtonum R15D = 13
    | regtonum EBP = 14		(* Dummy numbers -- not permitted for allocation, but there so that we can compare *)
    | regtonum RSP = 15

  (* gives reg associated with number (color) *)
  fun numtoreg 0 = EAX
    | numtoreg 1 = ESI
    | numtoreg 2 = EDI
    | numtoreg 3 = ECX
    | numtoreg 4 = R8D
    | numtoreg 5 = R9D
    | numtoreg 6 = EDX
    | numtoreg 7 = R10D
    | numtoreg 8 = R11D
    | numtoreg 9 = EBX
    | numtoreg 10 = R12D
    | numtoreg 11 = R13D
    | numtoreg 12 = R14D
    | numtoreg 13 = R15D
    | numtoreg n = raise ErrorMsg.InternalError ("numtoreg: Unknown register "^(Int.toString n))

  (* register compare *)
  fun regcmp (r1, r2) = Int.compare (regtonum r1, regtonum r2)

  (* operand compare; arbitrary order imposed to make
   * various things easier (e.g. liveness, for sorting)
   *)
  fun cmpoper (REG(reg1), REG(reg2)) = regcmp (reg1, reg2)
    | cmpoper (TEMP(temp1), TEMP(temp2)) = Temp.compare (temp1,temp2)
    | cmpoper (CONST(const1), CONST(const2)) = Word32.compare (const1, const2)
    | cmpoper (REL (r1, i1), REL (r2, i2)) =
        let 
          val regorder = regcmp (r1, r2)
          val intorder = Int.compare (i1, i2)
        in
          if (regorder = EQUAL) then intorder
          else regorder
        end
    | cmpoper (CONST _, _) = LESS
    | cmpoper (REG _, _) = LESS
    | cmpoper (REL _, _) = LESS
    | cmpoper (_, _) = GREATER

  fun opereq (REG a, REG b) = a = b
    | opereq (TEMP a, TEMP b) = Temp.eq (a, b)
    | opereq (CONST a, CONST b) = a = b
    | opereq (REL (ra, ia), REL (rb, ib)) = (ra = rb) andalso (ia = ib)
    | opereq (_, _) = false
    
  structure OperSet = ListSetFn (
    struct
      type ord_key = oper
      val compare = cmpoper
    end)
  
  structure LiveMap = SplayMapFn(struct
                                   type ord_key = int
                                   val compare = Int.compare
                                 end)
  
  fun opsused nil = OperSet.empty
    | opsused ((DIRECTIVE _)::l) = opsused l
    | opsused ((COMMENT _)::l) = opsused l
    | opsused ((LABEL _)::l) = opsused l
    | opsused ((MOV (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
    | opsused ((SUB (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
    | opsused ((IMUL (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
    | opsused ((IMUL3 (dst, src, _))::l) = OperSet.addList (opsused l, [dst, src])
    | opsused ((ADD (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
    | opsused ((IDIV (src))::l) = OperSet.addList (opsused l, [src, REG EDX, REG EAX])
    | opsused ((NEG (dst))::l) = OperSet.addList (opsused l, [dst])
    | opsused ((NOT (dst))::l) = OperSet.addList (opsused l, [dst])
    | opsused ((SAL (dst, shft))::l) = OperSet.addList (opsused l, [dst, shft])
    | opsused ((SAR (dst, shft))::l) = OperSet.addList (opsused l, [dst, shft])
    | opsused ((AND (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
    | opsused ((OR (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
    | opsused ((XOR (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
    | opsused ((CMP (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
    | opsused ((TEST (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
    | opsused ((SETcc (c, dst))::l) = OperSet.addList (opsused l, [dst])
    | opsused ((JMP _)::l) = opsused l
    | opsused ((Jcc _)::l) = opsused l
    | opsused ((CALL _)::l) = opsused l
    | opsused ((MOVZB (dst, src))::l) = OperSet.addList (opsused l, [dst, src])
    | opsused ((CLTD)::l) = opsused l
    | opsused ((RET)::l) = opsused l
    | opsused ((LIVEIGN i)::l) = opsused (i::l)
    | opsused ((SIZE (_, i))::l) = opsused (i::l)

  (* integer tostring, except with more - and less ~ *)
  fun moreDifferentToString (i) =
       if (i >= 0) then Int.toString i
       else "-" ^ (Int.toString (~i))

  (* pretty prints an operand *)  
  fun sfx Byte = "b"
    | sfx Word = "w"
    | sfx Long = "l"
    | sfx Qword = "q"
  
  fun prettyprint_oper s (REG r) = "%" ^ (regname s r)
    | prettyprint_oper s (TEMP t) = (Temp.name t) ^ (sfx s)
    | prettyprint_oper _ (CONST c) = "$0x" ^ (Word32.toString c)
    | prettyprint_oper _ (REL (r, i)) = (moreDifferentToString i) ^ "(%" ^ (regname Qword r) ^ ")"
    | prettyprint_oper _ (STR s) = s
    | prettyprint_oper _ (STACKARG i) = "arg#"^Int.toString i

  (* pretty prints (no...) *)
  fun prettyprint s (DIRECTIVE(str)) = str ^ "\n"
    | prettyprint s (COMMENT(str)) = "// " ^ str ^ "\n"
    | prettyprint s (LABEL(l)) = Label.name l ^ ":\n"
    | prettyprint s (MOV(dst, src)) = "\tmov" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
    | prettyprint s (SUB(dst, src)) = "\tsub" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
    | prettyprint s (IMUL(dst, src)) = "\timul\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
    | prettyprint s (IMUL3(dst, tmp, const)) = "\timul\t" ^ (prettyprint_oper s (CONST const)) ^ ", " ^ (prettyprint_oper s tmp) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
    | prettyprint s (ADD(dst, src)) = "\tadd" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
    | prettyprint s (IDIV(src)) = "\tidiv" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ "\n"
    | prettyprint s (NEG (dst)) = "\tneg" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s dst) ^ "\n"
    | prettyprint s (NOT (dst)) = "\tnot" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s dst) ^ "\n"
    | prettyprint s (SAL (dst, shft)) = "\tsal" ^ (sfx s) ^ "\t" ^ (prettyprint_oper Byte shft) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
    | prettyprint s (SAR (dst, shft)) = "\tsar" ^ (sfx s) ^ "\t" ^ (prettyprint_oper Byte shft) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
    | prettyprint s (AND (dst, src)) = "\tand" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
    | prettyprint s (OR (dst, src)) = "\tor" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
    | prettyprint s (XOR (dst, src)) = "\txor" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
    | prettyprint s (CMP (dst, src)) = "\tcmp" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
    | prettyprint s (TEST (dst, src)) = "\ttest" ^ (sfx s) ^ "\t" ^ (prettyprint_oper s src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
    | prettyprint s (SETcc (c, dst)) = "\tset" ^ (ccname c) ^ "\t" ^ (prettyprint_oper Byte dst) ^ "\n"
    | prettyprint s (JMP (label)) = "\tjmp\t" ^ (Label.name label) ^ "\n"
    | prettyprint s (Jcc (c,label)) = "\tj" ^ (ccname c) ^ "\t" ^ (Label.name label) ^ "\n"
    | prettyprint s (CALL (l,n)) = "\tcall\t" ^ Symbol.name l ^ "\t # (" ^ Int.toString n ^ "args)\n"
    | prettyprint s (MOVZB (dst, src)) = "\tmovzb" ^ (sfx s) ^ "\t" ^ (prettyprint_oper Byte src) ^ ", " ^ (prettyprint_oper s dst) ^ "\n"
    | prettyprint s (CLTD) = "\tcltd\n"
    | prettyprint s (RET) = "\tret\n"
    | prettyprint s (LIVEIGN i) = prettyprint s i
    | prettyprint _ (SIZE (s, i)) = prettyprint s i
(*    | prettyprint _ = raise ErrorMsg.InternalError ("prettyprint: Type A? Hatchar de coneccion?")*)
end