Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/MLRISC/x86/mltree/x86.sml
ViewVC logotype

Diff of /sml/trunk/src/MLRISC/x86/mltree/x86.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

sml/branches/SMLNJ/src/MLRISC/x86/mltree/x86.sml revision 247, Sat Apr 17 18:47:13 1999 UTC sml/trunk/src/MLRISC/x86/mltree/x86.sml revision 1003, Fri Dec 7 02:45:32 2001 UTC
# Line 1  Line 1 
1  (* X86.sml -- pattern matching version of x86 instruction set generation.  (*
2   *   *
3   * COPYRIGHT (c) 1998 Bell Laboratories.   * COPYRIGHT (c) 1998 Bell Laboratories.
4   *   *
5     * This is a revised version that takes into account of
6     * the extended x86 instruction set, and has better handling of
7     * non-standard types.  I've factored out the integer/floating point
8     * comparison code, added optimizations for conditional moves.
9     * The latter generates SETcc and CMOVcc (Pentium Pro only) instructions.
10     * To avoid problems, I have tried to incorporate as much of
11     * Lal's original magic incantations as possible.
12     *
13     * Some changes:
14     *
15     *  1.  REMU/REMS/REMT are now supported
16     *  2.  COND is supported by generating SETcc and/or CMOVcc; this
17     *      may require at least a Pentium II to work.
18     *  3.  Division by a constant has been optimized.   Division by
19     *      a power of 2 generates SHRL or SARL.
20     *  4.  Better addressing mode selection has been implemented.  This should
21     *      improve array indexing on SML/NJ.
22     *  5.  Generate testl/testb instead of andl whenever appropriate.  This
23     *      is recommended by the Intel Optimization Guide and seems to improve
24     *      boxity tests on SML/NJ.
25     *
26     * More changes for floating point:
27     *  A new mode is implemented which generates pseudo 3-address instructions
28     * for floating point.  These instructions are register allocated the
29     * normal way, with the virtual registers mapped onto a set of pseudo
30     * %fp registers.  These registers are then mapped onto the %st registers
31     * with a new postprocessing phase.
32     *
33     * -- Allen
34   *)   *)
35    local
36       val rewriteMemReg = true (* should we rewrite memRegs *)
37       val enableFastFPMode = true (* set this to false to disable the mode *)
38    in
39    
40  functor X86  functor X86
41    (structure X86Instr : X86INSTR    (structure X86Instr : X86INSTR
42     structure X86MLTree : MLTREE     structure MLTreeUtils : MLTREE_UTILS
43       where Region = X86Instr.Region                          where T = X86Instr.T
44         and Constant = X86Instr.Constant     structure ExtensionComp : MLTREE_EXTENSION_COMP
45     structure Flowgen : FLOWGRAPH_GEN                          where I = X86Instr and T = X86Instr.T
46       where I = X86Instr  and T = X86MLTree and B = X86MLTree.BNames     structure MLTreeStream : MLTREE_STREAM
47     val tempMem : X86Instr.operand) : MLTREECOMP =                          where T = ExtensionComp.T
48        datatype arch = Pentium | PentiumPro | PentiumII | PentiumIII
49        val arch : arch ref
50        val cvti2f :
51             {ty: X86Instr.T.ty,
52              src: X86Instr.operand,
53                 (* source operand, guaranteed to be non-memory! *)
54              an: Annotations.annotations ref (* cluster annotations *)
55             } ->
56             {instrs : X86Instr.instruction list,(* the instructions *)
57              tempMem: X86Instr.operand,         (* temporary for CVTI2F *)
58              cleanup: X86Instr.instruction list (* cleanup code *)
59             }
60        (* When the following flag is set, we allocate floating point registers
61         * directly on the floating point stack
62         *)
63        val fast_floating_point : bool ref
64      ) : sig include MLTREECOMP
65              val rewriteMemReg : bool
66          end =
67  struct  struct
   structure F = Flowgen  
   structure T = X86MLTree  
68    structure I = X86Instr    structure I = X86Instr
69    structure C = X86Cells    structure T = I.T
70      structure TS = ExtensionComp.TS
71      structure C = I.C
72      structure Shuffle = Shuffle(I)
73    structure W32 = Word32    structure W32 = Word32
74    structure LE = LabelExp    structure A = MLRiscAnnotations
75      structure CFG = ExtensionComp.CFG
76      structure CB = CellsBasis
77    
78      type instrStream = (I.instruction,C.cellset,CFG.cfg) TS.stream
79      type mltreeStream = (T.stm,T.mlrisc list,CFG.cfg) TS.stream
80    
81      datatype kind = REAL | INTEGER
82    
83      structure Gen = MLTreeGen
84         (structure T = T
85          val intTy = 32
86          val naturalWidths = [32]
87          datatype rep = SE | ZE | NEITHER
88          val rep = NEITHER
89         )
90    
91      fun error msg = MLRiscErrorMsg.error("X86",msg)
92    
93      (* Should we perform automatic MemReg translation?
94       * If this is on, we can avoid doing RewritePseudo phase entirely.
95       *)
96      val rewriteMemReg = rewriteMemReg
97    
98    fun error msg = MLRiscErrorMsg.impossible ("X86." ^ msg)    (* The following hardcoded *)
99      fun isMemReg r = rewriteMemReg andalso
100                       let val r = CB.registerNum r
101                       in  r >= 8 andalso r < 32
102                       end
103      fun isFMemReg r = if enableFastFPMode andalso !fast_floating_point
104                        then let val r = CB.registerNum r
105                             in r >= 8 andalso r < 32 end
106                        else true
107      val isAnyFMemReg = List.exists (fn r =>
108                                      let val r = CB.registerNum r
109                                      in  r >= 8 andalso r < 32 end
110                                     )
111    
112      val ST0 = C.ST 0
113      val ST7 = C.ST 7
114      val one = T.I.int_1
115    
116      val opcodes8 = {INC=I.INCB,DEC=I.DECB,ADD=I.ADDB,SUB=I.SUBB,
117                      NOT=I.NOTB,NEG=I.NEGB,
118                      SHL=I.SHLB,SHR=I.SHRB,SAR=I.SARB,
119                      OR=I.ORB,AND=I.ANDB,XOR=I.XORB}
120      val opcodes16 = {INC=I.INCW,DEC=I.DECW,ADD=I.ADDW,SUB=I.SUBW,
121                       NOT=I.NOTW,NEG=I.NEGW,
122                       SHL=I.SHLW,SHR=I.SHRW,SAR=I.SARW,
123                       OR=I.ORW,AND=I.ANDW,XOR=I.XORW}
124      val opcodes32 = {INC=I.INCL,DEC=I.DECL,ADD=I.ADDL,SUB=I.SUBL,
125                       NOT=I.NOTL,NEG=I.NEGL,
126                       SHL=I.SHLL,SHR=I.SHRL,SAR=I.SARL,
127                       OR=I.ORL,AND=I.ANDL,XOR=I.XORL}
128    
129      (*
130       * The code generator
131       *)
132      fun selectInstructions
133           (instrStream as
134            TS.S.STREAM{emit=emitInstruction,defineLabel,entryLabel,pseudoOp,
135                        annotation,getAnnotations,beginCluster,endCluster,exitBlock,comment,...}) =
136      let
137          val emit = emitInstruction o I.INSTR
138          exception EA
139    
140    (* label where a trap is generated -- one per cluster *)    (* label where a trap is generated -- one per cluster *)
141    val trapLabel = ref (NONE: Label.label option)        val trapLabel = ref (NONE: (I.instruction * Label.label) option)
142    
143          (* flag floating point generation *)
144          val floatingPointUsed = ref false
145    
146          (* effective address of an integer register *)
147          fun IntReg r = if isMemReg r then I.MemReg r else I.Direct r
148          and RealReg r = if isFMemReg r then I.FDirect r else I.FPR r
149    
150          (* Add an overflow trap *)
151          fun trap() =
152          let val jmp =
153                case !trapLabel of
154                  NONE => let val label = Label.label "trap" ()
155                              val jmp   = I.jcc{cond=I.O,
156                                                opnd=I.ImmedLabel(T.LABEL label)}
157                          in  trapLabel := SOME(jmp, label); jmp end
158                | SOME(jmp, _) => jmp
159          in  emitInstruction jmp end
160    
   val emitInstr = F.emitInstr  
   val emit    = F.emitInstr  
161    val newReg  = C.newReg    val newReg  = C.newReg
162    val newFreg = C.newFreg    val newFreg = C.newFreg
163    
164          fun fsize 32 = I.FP32
165            | fsize 64 = I.FP64
166            | fsize 80 = I.FP80
167            | fsize _  = error "fsize"
168    
169          (* mark an expression with a list of annotations *)
170          fun mark'(i,[]) = i
171            | mark'(i,a::an) = mark'(I.ANNOTATION{i=i,a=a},an)
172    
173          (* annotate an expression and emit it *)
174          fun mark(i,an) = emitInstruction(mark'(I.INSTR i,an))
175    
176          val emits = app emitInstruction
177    
178          (* emit parallel copies for integers
179           * Translates parallel copies that involve memregs into
180           * individual copies.
181           *)
182          fun copy([], [], an) = ()
183            | copy(dst, src, an) =
184              let fun mvInstr{dst as I.MemReg rd, src as I.MemReg rs} =
185                      if CB.sameColor(rd,rs) then [] else
186                      let val tmpR = I.Direct(newReg())
187                      in  [I.move{mvOp=I.MOVL, src=src, dst=tmpR},
188                           I.move{mvOp=I.MOVL, src=tmpR, dst=dst}]
189                      end
190                    | mvInstr{dst=I.Direct rd, src=I.Direct rs} =
191                        if CB.sameColor(rd,rs) then []
192                        else [I.copy{dst=[rd], src=[rs], tmp=NONE}]
193                    | mvInstr{dst, src} = [I.move{mvOp=I.MOVL, src=src, dst=dst}]
194              in
195                 emits (Shuffle.shuffle{mvInstr=mvInstr, ea=IntReg}
196                   {tmp=SOME(I.Direct(newReg())),
197                    dst=dst, src=src})
198              end
199    
200    (* conversions *)    (* conversions *)
201    val itow = Word.fromInt    val itow = Word.fromInt
202    val wtoi = Word.toInt    val wtoi = Word.toInt
203    val toInt32 = Int32.fromLarge o Int.toLarge        fun toInt32 i = T.I.toInt32(32, i)
204          val w32toi32 = Word32.toLargeIntX
205          val i32tow32 = Word32.fromLargeInt
206    
207    (* One day, this is going to bite us when precision(LargeInt)>32 *)    (* One day, this is going to bite us when precision(LargeInt)>32 *)
208    val wToInt32 = Int32.fromLarge o Word32.toLargeIntX        fun wToInt32 w = Int32.fromLarge(Word32.toLargeIntX w)
209    
210    (* some useful registers *)    (* some useful registers *)
211    val eax = I.Direct(C.eax)    val eax = I.Direct(C.eax)
212    val ecx = I.Direct(C.ecx)    val ecx = I.Direct(C.ecx)
213    val edx = I.Direct(C.edx)    val edx = I.Direct(C.edx)
214    
215    fun immed8 n = Int32.>=(n, ~256) andalso Int32.<(n,256)        fun immedLabel lab = I.ImmedLabel(T.LABEL lab)
   fun immedLabel lab = I.ImmedLabel(LE.LABEL lab)  
216    
217    fun move(src as I.Direct s, dst as I.Direct d) =        (* Is the expression zero? *)
218        if s=d then ()        fun isZero(T.LI z) = T.I.isZero z
219        else emit(I.COPY{dst=[d], src=[s], tmp=NONE})          | isZero(T.MARK(e,a)) = isZero e
220      | move(src, dst) =  emit(I.MOVE{mvOp=I.MOVL, src=src, dst=dst})          | isZero _ = false
221           (* Does the expression set the zero bit?
222    fun moveToReg opnd = let          * WARNING: we assume these things are not optimized out!
223      val dst = I.Direct(newReg())          *)
224    in move(opnd, dst); dst        fun setZeroBit(T.ANDB _)     = true
225    end          | setZeroBit(T.ORB _)      = true
226            | setZeroBit(T.XORB _)     = true
227    (* ensure that the operand is either an immed or register *)          | setZeroBit(T.SRA _)      = true
228    fun immedOrReg opnd =          | setZeroBit(T.SRL _)      = true
229      case opnd          | setZeroBit(T.SLL _)      = true
230       of I.Displace _ => moveToReg opnd          | setZeroBit(T.SUB _)      = true
231        | I.Indexed _ =>  moveToReg opnd          | setZeroBit(T.ADDT _)     = true
232        | _  => opnd          | setZeroBit(T.SUBT _)     = true
233      (*esac*)          | setZeroBit(T.MARK(e, _)) = setZeroBit e
234            | setZeroBit _             = false
235    
236          fun setZeroBit2(T.ANDB _)     = true
237            | setZeroBit2(T.ORB _)      = true
238            | setZeroBit2(T.XORB _)     = true
239            | setZeroBit2(T.SRA _)      = true
240            | setZeroBit2(T.SRL _)      = true
241            | setZeroBit2(T.SLL _)      = true
242            | setZeroBit2(T.ADD(32, _, _)) = true (* can't use leal! *)
243            | setZeroBit2(T.SUB _)      = true
244            | setZeroBit2(T.ADDT _)     = true
245            | setZeroBit2(T.SUBT _)     = true
246            | setZeroBit2(T.MARK(e, _)) = setZeroBit2 e
247            | setZeroBit2 _             = false
248    
249    fun isImmediate(I.Immed _) = true        (* emit parallel copies for floating point
250      | isImmediate(I.ImmedLabel _) = true         * Normal version.
251      | isImmediate(I.Const _) = true         *)
252      | isImmediate(I.LabelEA _) = true        fun fcopy'(fty, [], [], _) = ()
253      | isImmediate _ = false          | fcopy'(fty, dst as [_], src as [_], an) =
254                mark(I.FCOPY{dst=dst,src=src,tmp=NONE}, an)
255            | fcopy'(fty, dst, src, an) =
256                mark(I.FCOPY{dst=dst,src=src,tmp=SOME(I.FDirect(newFreg()))}, an)
257    
258          (* emit parallel copies for floating point.
259           * Fast version.
260           * Translates parallel copies that involve memregs into
261           * individual copies.
262           *)
263    
264    fun regOrMem opnd = if isImmediate opnd then moveToReg opnd else opnd        fun fcopy''(fty, [], [], _) = ()
265            | fcopy''(fty, dst, src, an) =
266              if true orelse isAnyFMemReg dst orelse isAnyFMemReg src then
267              let val fsize = fsize fty
268                  fun mvInstr{dst, src} = [I.fmove{fsize=fsize, src=src, dst=dst}]
269              in
270                  emits (Shuffle.shuffle{mvInstr=mvInstr, ea=RealReg}
271                    {tmp=case dst of
272                           [_] => NONE
273                         |  _  => SOME(I.FPR(newReg())),
274                     dst=dst, src=src})
275              end
276              else
277                mark(I.FCOPY{dst=dst,src=src,tmp=
278                             case dst of
279                               [_] => NONE
280                             | _   => SOME(I.FPR(newFreg()))}, an)
281    
282          fun fcopy x = if enableFastFPMode andalso !fast_floating_point
283                        then fcopy'' x else fcopy' x
284    
285  fun rexp(T.REG r) = ["r" ^ Int.toString r]        (* Translates MLTREE condition code to x86 condition code *)
286    | rexp(T.LI i)  = ["LI"]        fun cond T.LT = I.LT | cond T.LTU = I.B
287    | rexp(T.LI32 i32) = ["LI32"]          | cond T.LE = I.LE | cond T.LEU = I.BE
288    | rexp(T.LABEL  le) = ["LABEL"]          | cond T.EQ = I.EQ | cond T.NE  = I.NE
289    | rexp(T.CONST  c) = ["CONST"]          | cond T.GE = I.GE | cond T.GEU = I.AE
290            | cond T.GT = I.GT | cond T.GTU = I.A
   | rexp(T.ADD  (e1, e2)) = ["ADD("] @ rexp e1 @ (","::rexp e2) @ [")"]  
   | rexp(T.SUB  (e1, e2, _)) = ["SUB"]  
   | rexp(T.MULU (e1, e2)) = ["MULU"]  
   | rexp(T.DIVU   (e1, e2, _)) =  ["DIVU"]  
   
   | rexp(T.ADDT  (e1, e2)) =   ["ADDT"]  
   | rexp(T.MULT   (e1, e2)) =  ["MULT"]  
   | rexp(T.SUBT    (e1, e2, _)) = ["SUBT"]  
   | rexp(T.DIVT    (e1, e2, _)) = ["DIVT"]  
   
   | rexp(T.LOAD8  (e, _)) = ["LOAD8("] @ rexp e @ [")"]  
   | rexp(T.LOAD32  (e, _)) = ["LOAD32"]  
   
   | rexp(T.ANDB   (e1, e2)) =  ["AND"]  
   | rexp(T.ORB     (e1, e2)) = ["OR"]  
   | rexp(T.XORB    (e1, e2)) = ["XOR"]  
   
   | rexp(T.SRA    (e1, e2, _)) = ["SRA("] @ rexp e1 @ (","::rexp e2) @ [")"]  
   | rexp(T.SRL    (e1, e2, _)) = ["SRL"]  
   | rexp(T.SLL    (e1, e2, _)) = ["SLL"]  
   
   | rexp(T.SEQ(s, e)) = ["SEQ("] @ stm s @ ("," :: rexp e) @ [")"]  
   
 and stm s =  
  (case s  
   of T.MV(r, e) => ["MV(", Int.toString r] @ (",":: rexp e) @ [")"]  
    | T.FMV _ => ["FMV"]  
    | T.COPY _  => ["COPY"]  
    | T.FCOPY _ => ["FCOPY"]  
    | T.JMP _ => ["JMP"]  
    | T.CALL _ => ["CALL"]  
    | T.RET  => ["RET"]  
    | T.STORE8 _ => ["STORE8"]  
    | T.STORE32 _ => ["STORE32"]  
    | T.STORED _ => ["STORED"]  
    | T.STORECC _ => ["STORECC"]  
    | T.BCC    _ => ["BCC"]  
    | T.FBCC   _ => ["FBCC"]  
   (*esac*))  
291    
292  fun prMLRisc s = print(concat(stm s))        fun zero dst = emit(I.BINARY{binOp=I.XORL, src=dst, dst=dst})
293    
294          (* Move and annotate *)
295          fun move'(src as I.Direct s, dst as I.Direct d, an) =
296              if CB.sameColor(s,d) then ()
297              else mark(I.COPY{dst=[d], src=[s], tmp=NONE}, an)
298            | move'(I.Immed 0, dst as I.Direct d, an) =
299                mark(I.BINARY{binOp=I.XORL, src=dst, dst=dst}, an)
300            | move'(src, dst, an) = mark(I.MOVE{mvOp=I.MOVL, src=src, dst=dst}, an)
301    
302          (* Move only! *)
303          fun move(src, dst) = move'(src, dst, [])
304    
305    exception EA        val readonly = I.Region.readonly
306    
307    (* return an index computation *)        (*
308    fun index(arg as (T.SLL(t, T.LI n, _))) =         * Compute an effective address.
309        if n > 0 andalso n <= 3 then {index=reduceReg t, scale=n}         *)
310        else {index=reduceReg arg, scale=0}        fun address(ea, mem) = let
311      | index t = {index=reduceReg t, scale=0}            (* Keep building a bigger and bigger effective address expressions
312               * The input is a list of trees
313    (* return effective address *)             * b -- base
314    and ea eatree = let             * i -- index
315      (* Need to ensure that the scale register is never %esp *)             * s -- scale
316      fun doImmed(n, I.Immed(k)) = (I.Immed(k+toInt32 n) handle Overflow => raise EA)             * d -- immed displacement
317        | doImmed(n, I.ImmedLabel le) = I.ImmedLabel(LE.PLUS(le, LE.CONST n))             *)
318        | doImmed(n, I.Const c) =            fun doEA([], b, i, s, d) = makeAddressingMode(b, i, s, d)
319            I.Displace{base=reduceReg(T.CONST c), disp=I.Immed(toInt32 n)}              | doEA(t::trees, b, i, s, d) =
320                  (case t of
321      fun doConst(c, I.Immed(0)) = I.Const c                   T.LI n   => doEAImmed(trees, toInt32 n, b, i, s, d)
322        | doConst(c, d) = I.Displace{base=reduceReg(T.CONST c), disp=d}                 | T.CONST _ => doEALabel(trees, t, b, i, s, d)
323                   | T.LABEL _ => doEALabel(trees, t, b, i, s, d)
324      fun doLabel(le, I.Immed(0)) = I.ImmedLabel le                 | T.LABEXP le => doEALabel(trees, le, b, i, s, d)
325        | doLabel(le, I.Immed(n)) = I.ImmedLabel(LE.PLUS(le, LE.CONST(Int32.toInt n)))                 | T.ADD(32, t1, t2 as T.REG(_,r)) =>
326        | doLabel(le, I.Const c) =                      if isMemReg r then doEA(t2::t1::trees, b, i, s, d)
327            I.Displace{base=reduceReg(T.CONST c), disp=I.ImmedLabel le}                      else doEA(t1::t2::trees, b, i, s, d)
328                   | T.ADD(32, t1, t2) => doEA(t1::t2::trees, b, i, s, d)
329      fun newDisp(n, combine, I.Displace{base, disp}) =                 | T.SUB(32, t1, T.LI n) =>
330            I.Displace{base=base, disp=combine(n, disp)}                      doEA(t1::T.LI(T.I.NEG(32,n))::trees, b, i, s, d)
331        | newDisp(n, combine, I.Indexed{base, index, scale, disp}) =                 | T.SLL(32, t1, T.LI n) => let
332            I.Indexed{base=base, index=index, scale=scale, disp=combine(n, disp)}                      val n = T.I.toInt(32, n)
       | newDisp(n, combine, disp) = combine(n, disp)  
   
     fun combineBase(tree, base) =  
       SOME(case base  
            of NONE => reduceReg tree  
             | SOME base => reduceReg(T.ADD(T.REG base, tree))  
            (*esac*))  
   
     (* keep building a bigger and bigger effective address expressions *)  
     fun doEA(T.LI n, mode) = newDisp(n, doImmed, mode)  
       | doEA(T.LABEL le, mode) = newDisp(le, doLabel, mode)  
       | doEA(T.CONST c, mode) = newDisp(c, doConst, mode)  
       | doEA(t0 as T.SLL(t, T.LI scale, _), mode) =  
         if scale >= 1 andalso scale <= 3 then  
          (case mode  
           of I.Displace{base, disp} =>  
               I.Indexed  
                 {base=SOME base, index=reduceReg t, scale=scale, disp=disp}  
            | I.Indexed{base, index, scale, disp} =>  
               I.Indexed{base=combineBase(t0,base),  
                         index=index, scale=scale, disp=disp}  
            | disp =>  
               I.Indexed{base=NONE, index=reduceReg t, scale=scale, disp=disp}  
          (*esac*))  
         else  
          (case mode  
           of I.Displace{base, disp} =>  
                I.Displace{base=Option.valOf(combineBase(t0, SOME base)), disp=disp}  
            | I.Indexed{base, index, scale, disp} =>  
                I.Indexed{base=combineBase(t0, base),  
                          index=index, scale=scale, disp=disp}  
            | disp => I.Displace{base=reduceReg(t0), disp=disp}  
          (*esac*))  
       | doEA(T.ADD(t1, t2 as T.REG _), mode) = doEA(t1, doEA(t2, mode))  
       | doEA(T.ADD(t1, t2), mode) = doEA(t2, doEA(t1, mode))  
       | doEA(T.SUB(t1, T.LI n, _), mode) = doEA(T.ADD(t1, T.LI (~n)), mode)  
       | doEA(t, I.Indexed{base, index, scale, disp}) =  
           I.Indexed{base=combineBase(t, base), index=index, scale=scale, disp=disp}  
       | doEA(T.REG r, I.Displace{base, disp}) =  
           I.Indexed{base=SOME base, index=r, scale=0, disp=disp}  
       | doEA(t, I.Displace{base, disp}) =  
           I.Indexed{base=SOME base, index=reduceReg t, scale=0, disp=disp}  
       | doEA(t, immed) = I.Displace{base=reduceReg t, disp=immed}  
333    in    in
334      case doEA(eatree, I.Immed 0)                     case n
335      of I.Immed _ => raise EA                     of 0 => displace(trees, t1, b, i, s, d)
336                        | 1 => indexed(trees, t1, t, 1, b, i, s, d)
337                        | 2 => indexed(trees, t1, t, 2, b, i, s, d)
338                        | 3 => indexed(trees, t1, t, 3, b, i, s, d)
339                        | _ => displace(trees, t, b, i, s, d)
340                     end
341                   | t => displace(trees, t, b, i, s, d)
342                  )
343    
344              (* Add an immed constant *)
345              and doEAImmed(trees, 0, b, i, s, d) = doEA(trees, b, i, s, d)
346                | doEAImmed(trees, n, b, i, s, I.Immed m) =
347                     doEA(trees, b, i, s, I.Immed(n+m))
348                | doEAImmed(trees, n, b, i, s, I.ImmedLabel le) =
349                     doEA(trees, b, i, s,
350                          I.ImmedLabel(T.ADD(32,le,T.LI(T.I.fromInt32(32, n)))))
351                | doEAImmed(trees, n, b, i, s, _) = error "doEAImmed"
352    
353              (* Add a label expression *)
354              and doEALabel(trees, le, b, i, s, I.Immed 0) =
355                     doEA(trees, b, i, s, I.ImmedLabel le)
356                | doEALabel(trees, le, b, i, s, I.Immed m) =
357                     doEA(trees, b, i, s,
358                          I.ImmedLabel(T.ADD(32,le,T.LI(T.I.fromInt32(32, m))))
359                          handle Overflow => error "doEALabel: constant too large")
360                | doEALabel(trees, le, b, i, s, I.ImmedLabel le') =
361                     doEA(trees, b, i, s, I.ImmedLabel(T.ADD(32,le,le')))
362                | doEALabel(trees, le, b, i, s, _) = error "doEALabel"
363    
364              and makeAddressingMode(NONE, NONE, _, disp) = disp
365                | makeAddressingMode(SOME base, NONE, _, disp) =
366                    I.Displace{base=base, disp=disp, mem=mem}
367                | makeAddressingMode(base, SOME index, scale, disp) =
368                    I.Indexed{base=base, index=index, scale=scale,
369                              disp=disp, mem=mem}
370    
371              (* generate code for tree and ensure that it is not in %esp *)
372              and exprNotEsp tree =
373                  let val r = expr tree
374                  in  if CB.sameColor(r, C.esp) then
375                         let val tmp = newReg()
376                         in  move(I.Direct r, I.Direct tmp); tmp end
377                      else r
378                  end
379    
380              (* Add a base register *)
381              and displace(trees, t, NONE, i, s, d) =  (* no base yet *)
382                   doEA(trees, SOME(expr t), i, s, d)
383                | displace(trees, t, b as SOME base, NONE, _, d) = (* no index *)
384                  (* make t the index, but make sure that it is not %esp! *)
385                  let val i = expr t
386                  in  if CB.sameColor(i, C.esp) then
387                        (* swap base and index *)
388                        if CB.sameColor(base, C.esp) then
389                           doEA(trees, SOME i, b, 0, d)
390                        else  (* base and index = %esp! *)
391                           let val index = newReg()
392                           in  move(I.Direct i, I.Direct index);
393                               doEA(trees, b, SOME index, 0, d)
394                           end
395                      else
396                        doEA(trees, b, SOME i, 0, d)
397                  end
398                | displace(trees, t, SOME base, i, s, d) = (* base and index *)
399                  let val b = expr(T.ADD(32,T.REG(32,base),t))
400                  in  doEA(trees, SOME b, i, s, d) end
401    
402              (* Add an indexed register *)
403              and indexed(trees, t, t0, scale, b, NONE, _, d) = (* no index yet *)
404                   doEA(trees, b, SOME(exprNotEsp t), scale, d)
405                | indexed(trees, _, t0, _, NONE, i, s, d) = (* no base *)
406                   doEA(trees, SOME(expr t0), i, s, d)
407                | indexed(trees, _, t0, _, SOME base, i, s, d) = (*base and index*)
408                   let val b = expr(T.ADD(32, t0, T.REG(32, base)))
409                   in  doEA(trees, SOME b, i, s, d) end
410    
411          in  case doEA([ea], NONE, NONE, 0, I.Immed 0) of
412                I.Immed _ => raise EA
413       | I.ImmedLabel le => I.LabelEA le       | I.ImmedLabel le => I.LabelEA le
414       | ea => ea       | ea => ea
415    end (* ea *)        end (* address *)
416    
417              (* reduce an expression into an operand *)
418          and operand(T.LI i) = I.Immed(toInt32(i))
419            | operand(x as (T.CONST _ | T.LABEL _)) = I.ImmedLabel x
420            | operand(T.LABEXP le) = I.ImmedLabel le
421            | operand(T.REG(_,r)) = IntReg r
422            | operand(T.LOAD(32,ea,mem)) = address(ea, mem)
423            | operand(t) = I.Direct(expr t)
424    
425    and operand(T.LI i) = I.Immed(toInt32 i)        and moveToReg(opnd) =
426      | operand(T.LI32 w) = I.Immed(wToInt32 w)            let val dst = I.Direct(newReg())
427      | operand(T.CONST c) = I.Const c            in  move(opnd, dst); dst
     | operand(T.LABEL lab) = I.ImmedLabel lab  
     | operand(T.REG r) = I.Direct r  
     | operand(T.LOAD32(t, _)) = ea t  
     | operand(t) = I.Direct(reduceReg(t))  
   
   (* operand with preferred target *)  
   and operandRd(T.LI i, _) = I.Immed (toInt32 i)  
     | operandRd(T.LI32 w, _) = I.Immed(wToInt32 w)  
     | operandRd(T.REG r, _)  = I.Direct r  
     | operandRd(T.LOAD32(t,_), _) = ea t  
     | operandRd(t, rd) = I.Direct(reduceRegRd(t, rd))  
   
   (* evaluate left-to-right or right-to-left *)  
   and ordered(e1, e2, T.LR) = (operand e1, operand e2)  
     | ordered(e1, e2, T.RL) = let  
         val opnd2 = operand e2  
       in (operand e1, opnd2)  
428        end        end
429    
430    and cond T.LT = I.LT  | cond T.LTU = I.B        and reduceOpnd(I.Direct r) = r
431      | cond T.LE = I.LE  | cond T.LEU = I.BE          | reduceOpnd opnd =
432      | cond T.EQ = I.EQ  | cond T.NEQ = I.NE            let val dst = newReg()
433      | cond T.GE = I.GE  | cond T.GEU = I.AE            in  move(opnd, I.Direct dst); dst
434      | cond T.GT = I.GT  | cond T.GTU = I.A            end
435    
436   (* reduce an MLRISC statement tree *)        (* ensure that the operand is either an immed or register *)
437    and reduceStm(T.MV(rd, exp)) = let        and immedOrReg(opnd as I.Displace _) = moveToReg opnd
438          fun mv src = emit(I.MOVE{mvOp=I.MOVL, src=src, dst=I.Direct rd})          | immedOrReg(opnd as I.Indexed _)  = moveToReg opnd
439        in          | immedOrReg(opnd as I.MemReg _)   = moveToReg opnd
440          case operandRd(exp, rd)          | immedOrReg(opnd as I.LabelEA _)  = moveToReg opnd
441           of opnd as I.Direct rd' => if rd'=rd then () else mv opnd          | immedOrReg opnd  = opnd
442            | opnd => mv opnd  
443        end        and isImmediate(I.Immed _) = true
444      | reduceStm(T.FMV(fd, T.FREG fs)) =          | isImmediate(I.ImmedLabel _) = true
445         if fs=fd then () else emit(I.COPY{dst=[fd], src=[fs], tmp=NONE})          | isImmediate _ = false
446      | reduceStm(T.FMV(fd, T.LOADD(t, _))) =  
447         (emit(I.FLD(ea t)); emit(I.FSTP(I.FDirect fd)))        and regOrMem opnd = if isImmediate opnd then moveToReg opnd else opnd
448      | reduceStm(T.FMV(fd, e)) = (reduceFexp e; emit(I.FSTP(I.FDirect fd)))  
449      | reduceStm(T.CCMV(0, exp)) = reduceCC(exp, 0)        and isMemOpnd opnd =
450      | reduceStm(T.CCMV _) = error "reduceStm: CCMV"            (case opnd of
451      | reduceStm(T.COPY(dst as [_], src)) =              I.Displace _ => true
452          emit(I.COPY{dst=dst, src=src, tmp=NONE})            | I.Indexed _  => true
453      | reduceStm(T.COPY(dst, src)) =            | I.MemReg _   => true
454          emit(I.COPY{dst=dst, src=src, tmp=SOME(I.Direct(newReg()))})            | I.LabelEA _  => true
455      | reduceStm(T.FCOPY(dst, src)) =            | I.FDirect f  => true
456          emit(I.FCOPY{dst=dst, src=src, tmp=SOME(I.FDirect(newFreg()))})            | _            => false
457      | reduceStm(T.JMP(T.LABEL lexp, labs)) = emit(I.JMP(I.ImmedLabel lexp, labs))            )
458      | reduceStm(T.JMP(exp, labs)) = emit(I.JMP (operand exp, labs))  
459      | reduceStm(T.CALL(t,def,use)) = let           (*
460         val addCCreg = C.addCell C.CC            * Compute an integer expression and put the result in
461         fun addList([], acc) = acc            * the destination register rd.
462           | addList(T.GPR(T.REG r)::regs, acc) = addList(regs, C.addReg(r, acc))            *)
463           | addList(T.FPR(T.FREG r)::regs, acc) = addList(regs, C.addFreg(r, acc))        and doExpr(exp, rd : CB.cell, an) =
464           | addList(T.CCR(T.CC cc)::regs, acc) = addList(regs, addCCreg(cc, acc))            let val rdOpnd = IntReg rd
465           | addList(_::regs, acc) = addList(regs, acc)  
466        in                fun equalRd(I.Direct r) = CB.sameColor(r, rd)
467          emit(I.CALL(operand t, addList(def,C.empty), addList(use,C.empty)))                  | equalRd(I.MemReg r) = CB.sameColor(r, rd)
468        end                  | equalRd _ = false
469      | reduceStm(T.RET) = emit(I.RET)  
470      | reduceStm(T.STORE8(t1, t2, ord)) = let                   (* Emit a binary operator.  If the destination is
471         val opnd = immedOrReg(operand t2)                    * a memReg, do something smarter.
472         val src =                    *)
473           (case opnd                fun genBinary(binOp, opnd1, opnd2) =
474            of I.Direct r => if r = C.eax then opnd else (move(opnd, eax); eax)                    if isMemReg rd andalso
475             | _ => opnd                       (isMemOpnd opnd1 orelse isMemOpnd opnd2) orelse
476            (*esac*))                       equalRd(opnd2)
477        in emit(I.MOVE{mvOp=I.MOVB, src=src, dst=ea t1})                    then
478        end                    let val tmpR = newReg()
479      | reduceStm(T.STORE32(t1, t2, _)) = move(immedOrReg(operand t2), ea t1)                        val tmp  = I.Direct tmpR
480      | reduceStm(T.STORED(t1, t2, _)) =                    in  move(opnd1, tmp);
481         (case t2                        mark(I.BINARY{binOp=binOp, src=opnd2, dst=tmp}, an);
482           of T.FREG fs => emit(I.FLD(I.FDirect fs))                        move(tmp, rdOpnd)
           | e => reduceFexp e  
         (*esac*);  
         emit(I.FSTP(ea t1)))  
     | reduceStm(T.STORECC _) = error "stmAction: STORECC"  
     | reduceStm(T.BCC(_, T.CMP(cc as (T.EQ | T.NEQ), t1, T.LI 0, _), lab)) = let  
         val opnd1 = operand t1  
         fun jcc() = emit(I.JCC{cond=cond cc, opnd=immedLabel lab})  
       in  
         case t1  
         of T.ANDB _ => jcc()  
          | T.ORB _ =>  jcc()  
          | T.XORB _ => jcc()  
          | T.SRA _ =>  jcc()  
          | T.SRL _ =>  jcc()  
          | T.SLL _ =>  jcc()  
          | _ => (emit(I.CMP{lsrc=opnd1, rsrc=I.Immed 0}); jcc())  
       end  
     | reduceStm(T.BCC(_, T.CMP(cc, t1, t2, ord), lab)) = let  
         fun swapcc T.LT = T.GT  | swapcc T.LTU = T.GTU  
           | swapcc T.LE = T.GE  | swapcc T.LEU = T.GEU  
           | swapcc T.EQ = T.EQ  | swapcc T.NEQ = T.NEQ  
           | swapcc T.GE = T.LE  | swapcc T.GEU = T.LEU  
           | swapcc T.GT = T.LT  | swapcc T.GTU = T.LTU  
   
         fun cmpAndBranch(cc, opnd1, opnd2) =  
           (emit(I.CMP{lsrc=opnd1, rsrc=opnd2});  
            emit(I.JCC{cond=cond cc, opnd=immedLabel lab}))  
   
   
         val (opnd1, opnd2) = ordered(t1, t2, ord)  
       in  
         if isImmediate opnd1 andalso isImmediate opnd2 then  
           cmpAndBranch(cc, moveToReg opnd1, opnd2)  
         else if isImmediate opnd1 then  
           cmpAndBranch(swapcc cc, opnd2, opnd1)  
         else if isImmediate opnd2 then  
           cmpAndBranch(cc, opnd1, opnd2)  
         else case (opnd1, opnd2)  
          of (_, I.Direct _) => cmpAndBranch(cc, opnd1, opnd2)  
           | (I.Direct _, _) => cmpAndBranch(cc, opnd1, opnd2)  
           | _ => cmpAndBranch(cc, moveToReg opnd1, opnd2)  
          (*esac*)  
483        end        end
     | reduceStm(T.BCC(cc, T.CC(0), lab)) =  
         emit(I.JCC{cond=cond cc, opnd=immedLabel lab})  
     | reduceStm(T.BCC _) = error "reduceStm: BCC"  
     | reduceStm(T.FBCC(_, T.FCMP(fcc, t1, t2, ord), lab)) = let  
         fun compare() = let  
           fun ignoreOrder (T.FREG _) = true  
             | ignoreOrder (T.LOADD _) = true  
             | ignoreOrder _ = false  
           fun t2t1 () = (reduceFexp t2; reduceFexp t1)  
         in  
           if ignoreOrder t1 orelse ignoreOrder t2 then t2t1()  
484            else            else
485              (case ord                       (move(opnd1, rdOpnd);
486                of T.RL => t2t1()                        mark(I.BINARY{binOp=binOp, src=opnd2, dst=rdOpnd}, an)
487                 | T.LR => (reduceFexp t1; reduceFexp t2; emit(I.FXCH))                       )
488              (*esac*));  
489            emit(I.FUCOMPP)                   (* Generate a binary operator; it may commute *)
490          end                fun binaryComm(binOp, e1, e2) =
491          fun branch() = let                let val (opnd1, opnd2) =
492            val eax = I.Direct C.eax                        case (operand e1, operand e2) of
493            fun andil i = emit(I.BINARY{binOp=I.AND, src=I.Immed(i), dst=eax})                          (x as I.Immed _, y)      => (y, x)
494            fun xoril i = emit(I.BINARY{binOp=I.XOR, src=I.Immed(i), dst=eax})                        | (x as I.ImmedLabel _, y) => (y, x)
495            fun cmpil i = emit(I.CMP{rsrc=I.Immed(i), lsrc=eax})                        | (x, y as I.Direct _)     => (y, x)
496            fun j(cc, lab) = emit(I.JCC{cond=cc, opnd=immedLabel lab})                        | (x, y)                   => (x, y)
497            fun sahf() = emit(I.SAHF)                in  genBinary(binOp, opnd1, opnd2)
498          in                end
499            case fcc  
500            of T.==   => (andil 0x4400; xoril 0x4000; j(I.EQ, lab))                   (* Generate a binary operator; non-commutative *)
501             | T.?<>  => (andil 0x4400; xoril 0x4000; j(I.NE, lab))                fun binary(binOp, e1, e2) =
502             | T.?    => (sahf(); j(I.P,lab))                    genBinary(binOp, operand e1, operand e2)
503             | T.<=>  => (sahf(); j(I.NP,lab))  
504             | T.>    => (andil 0x4500;  j(I.EQ,lab))                   (* Generate a unary operator *)
505             | T.?<=  => (andil 0x4500;  j(I.NE,lab))                fun unary(unOp, e) =
506             | T.>=   => (andil 0x500; j(I.EQ,lab))                let val opnd = operand e
507             | T.?<   => (andil 0x500; j(I.NE,lab))                in  if isMemReg rd andalso isMemOpnd opnd then
508             | T.<    => (andil 0x4500; cmpil 0x100; j(I.EQ,lab))                       let val tmp = I.Direct(newReg())
509             | T.?>=  => (andil 0x4500; cmpil 0x100; j(I.NE,lab))                       in  move(opnd, tmp); move(tmp, rdOpnd)
510             | T.<=   => (andil 0x4100; cmpil 0x100; j(I.EQ,lab);                       end
511                          cmpil 0x4000; j(I.EQ,lab))                    else move(opnd, rdOpnd);
512             | T.?>   => (sahf(); j(I.P,lab); andil 0x4100; j(I.EQ,lab))                    mark(I.UNARY{unOp=unOp, opnd=rdOpnd}, an)
513             | T.<>   => (andil 0x4400; j(I.EQ,lab))                end
514             | T.?=   => (andil 0x4400; j(I.NE,lab))  
515           (*esac*)                   (* Generate shifts; the shift
516                      * amount must be a constant or in %ecx *)
517                  fun shift(opcode, e1, e2) =
518                  let val (opnd1, opnd2) = (operand e1, operand e2)
519                  in  case opnd2 of
520                        I.Immed _ => genBinary(opcode, opnd1, opnd2)
521                      | _ =>
522                        if equalRd(opnd2) then
523                        let val tmpR = newReg()
524                            val tmp  = I.Direct tmpR
525                        in  move(opnd1, tmp);
526                            move(opnd2, ecx);
527                            mark(I.BINARY{binOp=opcode, src=ecx, dst=tmp},an);
528                            move(tmp, rdOpnd)
529                        end
530                        else
531                            (move(opnd1, rdOpnd);
532                             move(opnd2, ecx);
533                             mark(I.BINARY{binOp=opcode, src=ecx, dst=rdOpnd},an)
534                            )
535                  end
536    
537                      (* Division or remainder: divisor must be in %edx:%eax pair *)
538                  fun divrem(signed, overflow, e1, e2, resultReg) =
539                  let val (opnd1, opnd2) = (operand e1, operand e2)
540                      val _ = move(opnd1, eax)
541                      val oper = if signed then (emit(I.CDQ); I.IDIVL1)
542                                 else (zero edx; I.DIVL1)
543                  in  mark(I.MULTDIV{multDivOp=oper, src=regOrMem opnd2},an);
544                      move(resultReg, rdOpnd);
545                      if overflow then trap() else ()
546                  end
547    
548                      (* Optimize the special case for division *)
549                  fun divide(signed, overflow, e1, e2 as T.LI n') = let
550                      val n = toInt32 n'
551                      val w = T.I.toWord32(32, n')
552                      fun isPowerOf2 w = W32.andb((w - 0w1), w) = 0w0
553                      fun log2 n =  (* n must be > 0!!! *)
554                          let fun loop(0w1,pow) = pow
555                                | loop(w,pow) = loop(W32.>>(w, 0w1),pow+1)
556                          in loop(n,0) end
557                  in  if n > 1 andalso isPowerOf2 w then
558                         let val pow = T.LI(T.I.fromInt(32,log2 w))
559                         in  if signed then
560                             (* signed; simulate round towards zero *)
561                             let val label = Label.anon()
562                                 val reg1  = expr e1
563                                 val opnd1 = I.Direct reg1
564                             in  if setZeroBit e1 then ()
565                                 else emit(I.CMPL{lsrc=opnd1, rsrc=I.Immed 0});
566                                 emit(I.JCC{cond=I.GE, opnd=immedLabel label});
567                                 emit(if n = 2 then
568                                         I.UNARY{unOp=I.INCL, opnd=opnd1}
569                                      else
570                                         I.BINARY{binOp=I.ADDL,
571                                                  src=I.Immed(n - 1),
572                                                  dst=opnd1});
573                                 defineLabel label;
574                                 shift(I.SARL, T.REG(32, reg1), pow)
575                             end
576                             else (* unsigned *)
577                                shift(I.SHRL, e1, pow)
578          end          end
579        in compare(); emit I.FNSTSW; branch()                    else
580                           (* note the only way we can overflow is if
581                            * n = 0 or n = -1
582                            *)
583                         divrem(signed, overflow andalso (n = ~1 orelse n = 0),
584                                e1, e2, eax)
585        end        end
586      | reduceStm(T.FBCC _) = error "reduceStm: FBCC"                  | divide(signed, overflow, e1, e2) =
587                        divrem(signed, overflow, e1, e2, eax)
588    
589    and reduceCC(T.CMP(_, t1, t2, ord), 0) = let                fun rem(signed, overflow, e1, e2) =
590          val (opnd1, opnd2) = ordered(t1, t2, ord)                      divrem(signed, overflow, e1, e2, edx)
       in  
         emit(I.CMP(  
           case (opnd1, opnd2)  
           of (I.Immed _, _) => {lsrc=moveToReg opnd1, rsrc=opnd2}  
            | (I.ImmedLabel _, _) => {lsrc=moveToReg opnd1, rsrc=opnd2}  
            | (I.Const _, _) => {lsrc=moveToReg opnd1, rsrc=opnd2}  
            | (I.Direct _, _) => {lsrc=opnd1, rsrc=opnd2}  
            | (_, I.Direct _) => {lsrc=opnd1, rsrc=opnd2}  
            | _ => {lsrc=moveToReg opnd1, rsrc=opnd2}))  
       end  
     | reduceCC _ = error "reduceCC"  
   
   
   and reduceReg(T.REG rd) = rd  
     | reduceReg(exp) = reduceRegRd(exp, newReg())  
   
  (* reduce to the register rd where possible.*)  
   and reduceRegRd(exp, rd) = let  
     val opndRd = I.Direct(rd)  
   
     fun binary(comm, oper, e1, e2, order) = let  
       fun emit2addr (opnd1, opnd2) =  
         (move(opnd1, opndRd);  
          emit(I.BINARY{binOp=oper, dst=opndRd, src=opnd2});  
          rd)  
       fun commute(opnd1 as I.Immed _, opnd2) = (opnd2, opnd1)  
         | commute(opnd1 as I.ImmedLabel _, opnd2) = (opnd2, opnd1)  
         | commute(opnd1 as I.Const _, opnd2) = (opnd2, opnd1)  
         | commute(opnd1, opnd2 as I.Direct _) = (opnd2, opnd1)  
         | commute arg = arg  
   
       val opnds = ordered(e1, e2, order)  
     in emit2addr(if comm then commute opnds else opnds)  
     end (*binary*)  
   
     fun unary(oper, exp) =  
       (move(operand exp, opndRd);  
        emit(I.UNARY{unOp=oper, opnd=opndRd});  
        rd)  
   
    (* The shift count can be either an immediate or the ECX register *)  
     fun shift(oper, e1, e2, order) = let  
       val (opnd1, opnd2) = ordered(e1, e2, order)  
     in  
       move(opnd1, opndRd);  
       case opnd2  
        of I.Immed _ => emit(I.BINARY{binOp=oper, src=opnd2, dst=opndRd})  
         | _ => (move(opnd2, ecx);  
                 emit(I.BINARY{binOp=oper, src=ecx, dst=opndRd}))  
       (*esac*);  
       rd  
     end (* shift *)  
591    
592      (* Divisor must be in EDX:EAX *)                    (* Makes sure the destination must be a register *)
593      fun divide(oper, signed, e1, e2, order) = let                fun dstMustBeReg f =
594        val (opnd1, opnd2) = ordered(e1, e2, order)                    if isMemReg rd then
595      in                    let val tmpR = newReg()
596        move(opnd1, eax);                        val tmp  = I.Direct(tmpR)
597        if signed then emit(I.CDQ) else move(I.Immed(0), edx);                    in  f(tmpR, tmp); move(tmp, rdOpnd) end
598        emit(I.MULTDIV{multDivOp=oper, src=regOrMem opnd2});                    else f(rd, rdOpnd)
       move(eax, opndRd);  
       rd  
     end  
599    
600      (* unsigned integer multiplication *)      (* unsigned integer multiplication *)
601      fun uMultiply(e1, e2) =      fun uMultiply(e1, e2) =
602        (* note e2 can never be (I.Direct edx) *)        (* note e2 can never be (I.Direct edx) *)
603        (move(operand e1, eax);        (move(operand e1, eax);
604         emit(I.MULTDIV{multDivOp=I.UMUL, src=regOrMem(operand e2)});                     mark(I.MULTDIV{multDivOp=I.MULL1,
605         move(eax, opndRd);                                    src=regOrMem(operand e2)},an);
606         rd)                     move(eax, rdOpnd)
607                      )
608    
609      (* signed integer multiplication *)                    (* signed integer multiplication:
610                       * The only forms that are allowed that also sets the
     (* The only forms that are allowed that also sets the  
611       * OF and CF flags are:       * OF and CF flags are:
612       *       *
613                       *          (dst)  (src1)  (src2)
614       *      imul r32, r32/m32, imm8       *      imul r32, r32/m32, imm8
615                       *          (dst)  (src)
616       *      imul r32, imm8       *      imul r32, imm8
617       *      imul r32, imm32       *      imul r32, imm32
618                       *      imul r32, r32/m32
619                       * Note: destination must be a register!
620       *)       *)
621      fun multiply(e1, e2) = let                fun multiply(e1, e2) =
622        fun doit(i1 as I.Immed _, i2 as I.Immed _) =                dstMustBeReg(fn (rd, rdOpnd) =>
623             (move(i1, opndRd);                let fun doit(i1 as I.Immed _, i2 as I.Immed _) =
624              emit(I.MUL3{dst=rd, src1=i2, src2=NONE}))                        (move(i1, rdOpnd);
625                           mark(I.BINARY{binOp=I.IMULL, dst=rdOpnd, src=i2},an))
626          | doit(rm, i2 as I.Immed _) = doit(i2, rm)          | doit(rm, i2 as I.Immed _) = doit(i2, rm)
627          | doit(imm as I.Immed(i), rm) =          | doit(imm as I.Immed(i), rm) =
628               emit(I.MUL3{dst=rd, src1=rm, src2=SOME i})                             mark(I.MUL3{dst=rd, src1=rm, src2=i},an)
629          | doit(r1 as I.Direct _, r2 as I.Direct _) =          | doit(r1 as I.Direct _, r2 as I.Direct _) =
630              (move(r1, opndRd);                        (move(r1, rdOpnd);
631               emit(I.MUL3{dst=rd, src1=r2, src2=NONE}))                         mark(I.BINARY{binOp=I.IMULL, dst=rdOpnd, src=r2},an))
632          | doit(r1 as I.Direct _, rm) =          | doit(r1 as I.Direct _, rm) =
633              (move(r1, opndRd);                        (move(r1, rdOpnd);
634               emit(I.MUL3{dst=rd, src1=rm, src2=NONE}))                         mark(I.BINARY{binOp=I.IMULL, dst=rdOpnd, src=rm},an))
635          | doit(rm, r as I.Direct _) = doit(r, rm)          | doit(rm, r as I.Direct _) = doit(r, rm)
636          | doit(rm1, rm2) =          | doit(rm1, rm2) =
637             (move(rm1, opndRd);                         if equalRd rm2 then
638              emit(I.MUL3{dst=rd, src1=rm2, src2=NONE}))                         let val tmpR = newReg()
639      in doit(ordered(e1, e2, T.LR))                             val tmp  = I.Direct tmpR
640                           in move(rm1, tmp);
641                              mark(I.BINARY{binOp=I.IMULL, dst=tmp, src=rm2},an);
642                              move(tmp, rdOpnd)
643      end      end
644                           else
645                             (move(rm1, rdOpnd);
646                              mark(I.BINARY{binOp=I.IMULL, dst=rdOpnd, src=rm2},an)
647                             )
648                      val (opnd1, opnd2) = (operand e1, operand e2)
649                  in  doit(opnd1, opnd2)
650                  end
651                  )
652    
653      fun trap() =                   (* Emit a load instruction; makes sure that the destination
654        (case !trapLabel                    * is a register
655         of NONE => (trapLabel := SOME(Label.newLabel "trap"); trap())                    *)
656          | SOME lab => emit(I.JCC{cond=I.O, opnd=I.ImmedLabel(LE.LABEL lab)})                fun genLoad(mvOp, ea, mem) =
657        (*esac*))                    dstMustBeReg(fn (_, dst) =>
658    in                       mark(I.MOVE{mvOp=mvOp, src=address(ea, mem), dst=dst},an))
659      case exp  
660       of T.REG rs => (move(I.Direct rs, opndRd); rd)                   (* Generate a zero extended loads *)
661        | T.LI n   => (move(I.Immed(toInt32 n), opndRd); rd)                fun load8(ea, mem) = genLoad(I.MOVZBL, ea, mem)
662        | T.LI32 w => (move(I.Immed(wToInt32 w), opndRd); rd)                fun load16(ea, mem) = genLoad(I.MOVZWL, ea, mem)
663        | T.CONST c => (move(I.Const c, opndRd); rd)                fun load8s(ea, mem) = genLoad(I.MOVSBL, ea, mem)
664        | T.LABEL lab => (move(I.ImmedLabel lab, opndRd); rd)                fun load16s(ea, mem) = genLoad(I.MOVSWL, ea, mem)
665        | T.ADD(e, T.LI 1) => unary(I.INC, e)                fun load32(ea, mem) = genLoad(I.MOVL, ea, mem)
666        | T.ADD(e, T.LI32 0w1) => unary(I.INC, e)  
667        | T.ADD(e, T.LI ~1) => unary(I.DEC, e)                   (* Generate a sign extended loads *)
668        | T.ADD(e1, e2) =>  
669            ((emit(I.LEA{r32=rd, addr=ea(exp)}); rd)                   (* Generate setcc instruction:
670              handle EA => binary(true, I.ADD, e1, e2, T.LR))                    *  semantics:  MV(rd, COND(_, T.CMP(ty, cc, t1, t2), yes, no))
671        | T.SUB(e, T.LI 1, _) => unary(I.DEC, e)                    * Bug, if eax is either t1 or t2 then problem will occur!!!
672        | T.SUB(e, T.LI32 0w1, _) => unary(I.DEC, e)                    * Note that we have to use eax as the destination of the
673        | T.SUB(e, T.LI ~1, _) => unary(I.INC, e)                    * setcc because it only works on the registers
674        | T.SUB(e1, e2, ord) => binary(false, I.SUB, e1, e2, ord)                    * %al, %bl, %cl, %dl and %[abcd]h.  The last four registers
675        | T.MULU(e1, e2) => uMultiply(e1, e2)                    * are inaccessible in 32 bit mode.
676        | T.DIVU(e1, e2, ord) => (divide(I.UDIV, false, e1, e2, ord))                    *)
677        | T.ADDT(e1, e2) => (binary(true,I.ADD,e1,e2,T.LR); trap(); rd)                fun setcc(ty, cc, t1, t2, yes, no) =
678        | T.MULT(e1, e2) => (multiply(e1, e2); trap(); rd)                let val (cc, yes, no) =
679        | T.SUBT(e1, e2, ord) =>                           if yes > no then (cc, yes, no)
680           (binary(false,I.SUB,e1,e2,ord); trap(); rd)                           else (T.Basis.negateCond cc, no, yes)
681        | T.DIVT(e1, e2, ord) =>                in  (* Clear the destination first.
682            (divide(I.IDIV, true, e1, e2, ord); trap(); rd)                     * This this because stupid SETcc
683        | T.LOAD32(exp, _) => (move(ea exp, opndRd); rd)                     * only writes to the low order
684        | T.LOAD8(exp, _) =>                     * byte.  That's Intel architecture, folks.
685            (emit(I.MOVE{mvOp=I.MOVZX, src=ea exp, dst=opndRd}); rd)                     *)
686        | T.ANDB(e1, e2) => binary(true, I.AND, e1, e2, T.LR)                    case (yes, no, cc) of
687        | T.ORB(e1, e2) => binary(true, I.OR, e1, e2, T.LR)                      (1, 0, T.LT) =>
688        | T.XORB(e1, e2) => binary(true, I.XOR, e1, e2, T.LR)                       let val tmp = I.Direct(expr(T.SUB(32,t1,t2)))
689        | T.SRA(e1, e2, ord) => shift(I.SAR, e1, e2, ord)                       in  move(tmp, rdOpnd);
690        | T.SRL(e1, e2, ord) => shift(I.SHR, e1, e2, ord)                           emit(I.BINARY{binOp=I.SHRL,src=I.Immed 31,dst=rdOpnd})
691        | T.SLL(e1, e2, ord) => shift(I.SHL, e1, e2, ord)                       end
692        | T.SEQ(stm, rexp)  => (reduceStm stm; reduceRegRd(rexp, rd))                    | (1, 0, T.GT) =>
693    end (* reduceRegRd *)                       let val tmp = I.Direct(expr(T.SUB(32,t1,t2)))
694                         in  emit(I.UNARY{unOp=I.NOTL,opnd=tmp});
695    and reduceFexp(fexp) = let                           move(tmp, rdOpnd);
696      val ST = I.FDirect 0                           emit(I.BINARY{binOp=I.SHRL,src=I.Immed 31,dst=rdOpnd})
697      val ST1 = I.FDirect 1                       end
698                      | (1, 0, _) => (* normal case *)
699      datatype su_numbers =                      let val cc = cmp(true, ty, cc, t1, t2, [])
700         LEAF of int                      in  mark(I.SET{cond=cond cc, opnd=eax}, an);
701       | BINARY of int * su_numbers * su_numbers                          emit(I.BINARY{binOp=I.ANDL,src=I.Immed 255, dst=eax});
702       | UNARY of int * su_numbers                          move(eax, rdOpnd)
703                        end
704      fun label(LEAF n) = n                    | (C1, C2, _)  =>
705        | label(BINARY(n, _, _)) = n                      (* general case;
706        | label(UNARY(n, _)) = n                       * from the Intel optimization guide p3-5
707                         *)
708      datatype direction = LEFT | RIGHT                      let val _  = zero eax;
709                            val cc = cmp(true, ty, cc, t1, t2, [])
710     (* Generate tree of sethi-ullman numbers *)                      in  case C1-C2 of
711      fun suBinary(t1, t2) = let                            D as (1 | 2 | 3 | 4 | 5 | 8 | 9) =>
712        val su1 = suNumbering(t1, LEFT)                            let val (base,scale) =
713        val su2 = suNumbering(t2, RIGHT)                                    case D of
714        val n1 = label su1                                      1 => (NONE, 0)
715        val n2 = label su2                                    | 2 => (NONE, 1)
716      in BINARY(if n1=n2 then n1+1 else Int.max(n1, n2), su1, su2)                                    | 3 => (SOME C.eax, 1)
717      end                                    | 4 => (NONE, 2)
718                                      | 5 => (SOME C.eax, 2)
719      and suUnary(t) = let                                    | 8 => (NONE, 3)
720        val su = suNumbering(t, LEFT)                                    | 9 => (SOME C.eax, 3)
721      in UNARY(label su, su)                                val addr = I.Indexed{base=base,
722      end                                                     index=C.eax,
723                                                       scale=scale,
724      and suNumbering(T.FREG _, LEFT) = LEAF 1                                                     disp=I.Immed C2,
725        | suNumbering(T.FREG _, RIGHT) = LEAF 0                                                     mem=readonly}
726        | suNumbering(T.LOADD _, LEFT) = LEAF 1                                val tmpR = newReg()
727        | suNumbering(T.LOADD _, RIGHT) = LEAF 0                                val tmp  = I.Direct tmpR
728        | suNumbering(T.FADDD(t1, t2), _) = suBinary(t1, t2)                            in  emit(I.SET{cond=cond cc, opnd=eax});
729        | suNumbering(T.FMULD(t1, t2), _) = suBinary(t1, t2)                                mark(I.LEA{r32=tmpR, addr=addr}, an);
730        | suNumbering(T.FSUBD(t1, t2, _), _) = suBinary(t1, t2)                                move(tmp, rdOpnd)
731        | suNumbering(T.FDIVD(t1, t2, _), _) = suBinary(t1, t2)                            end
732        | suNumbering(T.FABSD t, _) = suUnary(t)                          | D =>
733        | suNumbering(T.FNEGD t, _) = suUnary(t)                             (emit(I.SET{cond=cond(T.Basis.negateCond cc),
734        | suNumbering(T.CVTI2D t, _) = UNARY(1, LEAF 0)                                         opnd=eax});
735                                emit(I.UNARY{unOp=I.DECL, opnd=eax});
736      fun leafEA(T.FREG f) = I.FDirect f                              emit(I.BINARY{binOp=I.ANDL,
737        | leafEA(T.LOADD(t, _)) = ea t                                            src=I.Immed D, dst=eax});
738        | leafEA _ = error "leafEA"                              if C2 = 0 then
739                                   move(eax, rdOpnd)
740                                else
741                                   let val tmpR = newReg()
742                                       val tmp  = I.Direct tmpR
743                                   in  mark(I.LEA{addr=
744                                             I.Displace{
745                                                 base=C.eax,
746                                                 disp=I.Immed C2,
747                                                 mem=readonly},
748                                                 r32=tmpR}, an);
749                                        move(tmp, rdOpnd)
750                                    end
751                               )
752                        end
753                  end (* setcc *)
754    
755      fun cvti2d(t) = let                    (* Generate cmovcc instruction.
756        val opnd = operand t                     * on Pentium Pro and Pentium II only
       fun doMemOpnd () =  
         (emit(I.MOVE{mvOp=I.MOVL, src=opnd, dst=tempMem});  
          emit(I.FILD tempMem))  
     in  
       case opnd  
       of I.Direct _ => doMemOpnd()  
        | I.Immed _ => doMemOpnd()  
        | _ => emit(I.FILD opnd)  
     end  
   
     (* traverse expression and su-number tree *)  
     fun gencode(_, LEAF 0) = ()  
       | gencode(f, LEAF 1) = emit(I.FLD(leafEA f))  
       | gencode(t, BINARY(_, su1, LEAF 0)) = let  
           fun doit(oper, t1, t2) =  
             (gencode(t1, su1);  
              emit(I.FBINARY{binOp=oper, src=leafEA t2, dst=ST}))  
         in  
           case t  
           of T.FADDD(t1, t2) => doit(I.FADD, t1, t2)  
            | T.FMULD(t1, t2) => doit(I.FMUL, t1, t2)  
            | T.FSUBD(t1, t2, _) => doit(I.FSUB, t1, t2)  
            | T.FDIVD(t1, t2, _) => doit(I.FDIV, t1, t2)  
         end  
       | gencode(fexp, BINARY(_, su1, su2)) = let  
           fun doit(t1, t2, oper, operP, operRP) = let  
            (* oper[P] =>  ST(1) := ST oper ST(1); [pop]  
             * operR[P] => ST(1) := ST(1) oper ST; [pop]  
757              *)              *)
758              val n1 = label su1                fun cmovcc(ty, cc, t1, t2, yes, no) =
759              val n2 = label su2                let fun genCmov(dstR, _) =
760                      let val _ = doExpr(no, dstR, []) (* false branch *)
761                          val cc = cmp(true, ty, cc, t1, t2, [])  (* compare *)
762                      in  mark(I.CMOV{cond=cond cc, src=operand yes, dst=dstR}, an)
763                      end
764                  in  dstMustBeReg genCmov
765                  end
766    
767                  fun unknownExp exp = doExpr(Gen.compileRexp exp, rd, an)
768    
769                      (* Add n to rd *)
770                  fun addN n =
771                  let val n = operand n
772                      val src = if isMemReg rd then immedOrReg n else n
773                  in  mark(I.BINARY{binOp=I.ADDL, src=src, dst=rdOpnd}, an) end
774    
775                      (* Generate addition *)
776                  fun addition(e1, e2) =
777                      case e1 of
778                        T.REG(_,rs) => if CB.sameColor(rs,rd) then addN e2
779                                       else addition1(e1,e2)
780                      | _ => addition1(e1,e2)
781                  and addition1(e1, e2) =
782                      case e2 of
783                        T.REG(_,rs) => if CB.sameColor(rs,rd) then addN e1
784                                       else addition2(e1,e2)
785                      | _ => addition2(e1,e2)
786                  and addition2(e1,e2) =
787                    (dstMustBeReg(fn (dstR, _) =>
788                        mark(I.LEA{r32=dstR, addr=address(exp, readonly)}, an))
789                    handle EA => binaryComm(I.ADDL, e1, e2))
790    
791    
792              in  case exp of
793                   T.REG(_,rs) =>
794                       if isMemReg rs andalso isMemReg rd then
795                          let val tmp = I.Direct(newReg())
796                          in  move'(I.MemReg rs, tmp, an);
797                              move'(tmp, rdOpnd, [])
798                          end
799                       else move'(IntReg rs, rdOpnd, an)
800                 | T.LI z => let
801                     val n = toInt32 z
802            in            in
803              if n1 < n2 andalso n1 <= 7 then                   if n=0 then
804                (gencode(t2, su2);                     (* As per Fermin's request, special optimization for rd := 0.
805                 gencode(t1, su1);                      * Currently we don't bother with the size.
806                 emit(I.FBINARY{binOp=operP, src=ST, dst=ST1}))                      *)
807              else if n2 <= n1 andalso n2 <= 7 then                     if isMemReg rd then move'(I.Immed 0, rdOpnd, an)
808                (gencode(t1, su1);                     else mark(I.BINARY{binOp=I.XORL, src=rdOpnd, dst=rdOpnd}, an)
809                 gencode(t2, su2);                   else
810                 emit(I.FBINARY{binOp=operRP, src=ST, dst=ST1}))                     move'(I.Immed(n), rdOpnd, an)
811              else let (* both labels > 7 *)                 end
812                  val fs = I.FDirect(newFreg())               | (T.CONST _ | T.LABEL _) =>
813                     move'(I.ImmedLabel exp, rdOpnd, an)
814                 | T.LABEXP le => move'(I.ImmedLabel le, rdOpnd, an)
815    
816                   (* 32-bit addition *)
817                 | T.ADD(32, e1, e2 as T.LI n) => let
818                     val n = toInt32 n
819                in                in
820                  gencode (t2, su2);                   case n
821                  emit(I.FSTP fs);                   of 1  => unary(I.INCL, e1)
822                  gencode (t1, su1);                    | ~1 => unary(I.DECL, e1)
823                  emit(I.FBINARY{binOp=oper, src=fs, dst=ST})                    | _ => addition(e1, e2)
824                end                end
825                 | T.ADD(32, e1 as T.LI n, e2) => let
826                     val n = toInt32 n
827                   in
828                     case n
829                     of  1 => unary(I.INCL, e2)
830                      | ~1 => unary(I.DECL, e2)
831                      | _ => addition(e1, e2)
832            end            end
833                 | T.ADD(32, e1, e2) => addition(e1, e2)
834    
835                   (* 32-bit addition but set the flag!
836                    * This is a stupid hack for now.
837                    *)
838                 | T.ADD(0, e, e1 as T.LI n) => let
839                     val n = T.I.toInt(32, n)
840                   in
841                     if n=1 then unary(I.INCL, e)
842                     else if n = ~1 then unary(I.DECL, e)
843                          else binaryComm(I.ADDL, e, e1)
844                   end
845                 | T.ADD(0, e1 as T.LI n, e) => let
846                     val n = T.I.toInt(32, n)
847          in          in
848            case fexp                   if n=1 then unary(I.INCL, e)
849            of T.FADDD(t1, t2) => doit(t1, t2, I.FADD, I.FADDP, I.FADDP)                   else if n = ~1 then unary(I.DECL, e)
850             | T.FMULD(t1, t2) => doit(t1, t2, I.FMUL, I.FMULP, I.FMULP)                        else binaryComm(I.ADDL, e1, e)
851             | T.FSUBD(t1, t2, _) => doit(t1, t2, I.FSUB, I.FSUBP, I.FSUBRP)                 end
852             | T.FDIVD(t1, t2, _) => doit(t1, t2, I.FDIV, I.FDIVP, I.FDIVRP)               | T.ADD(0, e1, e2) => binaryComm(I.ADDL, e1, e2)
853          end  
854        | gencode(fexp, UNARY(_, LEAF 0)) =                 (* 32-bit subtraction *)
855          (case fexp               | T.SUB(32, e1, e2 as T.LI n) => let
856            of T.FABSD t => (emit(I.FLD(leafEA t)); emit(I.FUNARY(I.FABS)))                   val n = toInt32 n
857             | T.FNEGD t => (emit(I.FLD(leafEA t)); emit(I.FUNARY(I.FCHS)))                 in
858             | T.CVTI2D t => cvti2d(t)                   case n
859           (*esac*))                   of 0 => doExpr(e1, rd, an)
860        | gencode(fexp, UNARY(_, su)) = let                    | 1 => unary(I.DECL, e1)
861            fun doit(oper, t) = (gencode(t, su); emit(I.FUNARY(oper)))                    | ~1 => unary(I.INCL, e1)
862          in                    | _ => binary(I.SUBL, e1, e2)
863            case fexp                 end
864             of T.FABSD t => doit(I.FABS, t)               | T.SUB(32, e1 as T.LI n, e2) =>
865              | T.FNEGD t => doit(I.FCHS, t)                   if T.I.isZero n then unary(I.NEGL, e2)
866              | T.CVTI2D _ => error "gencode:UNARY:cvti2d"                   else binary(I.SUBL, e1, e2)
867                 | T.SUB(32, e1, e2) => binary(I.SUBL, e1, e2)
868    
869                 | T.MULU(32, x, y) => uMultiply(x, y)
870                 | T.DIVU(32, x, y) => divide(false, false, x, y)
871                 | T.REMU(32, x, y) => rem(false, false, x, y)
872    
873                 | T.MULS(32, x, y) => multiply(x, y)
874                 | T.DIVS(32, x, y) => divide(true, false, x, y)
875                 | T.REMS(32, x, y) => rem(true, false, x, y)
876    
877                 | T.ADDT(32, x, y) => (binaryComm(I.ADDL, x, y); trap())
878                 | T.SUBT(32, x, y) => (binary(I.SUBL, x, y); trap())
879                 | T.MULT(32, x, y) => (multiply(x, y); trap())
880                 | T.DIVT(32, x, y) => divide(true, true, x, y)
881                 | T.REMT(32, x, y) => rem(true, true, x, y)
882    
883                 | T.ANDB(32, x, y) => binaryComm(I.ANDL, x, y)
884                 | T.ORB(32, x, y)  => binaryComm(I.ORL, x, y)
885                 | T.XORB(32, x, y) => binaryComm(I.XORL, x, y)
886                 | T.NOTB(32, x)    => unary(I.NOTL, x)
887    
888                 | T.SRA(32, x, y)  => shift(I.SARL, x, y)
889                 | T.SRL(32, x, y)  => shift(I.SHRL, x, y)
890                 | T.SLL(32, x, y)  => shift(I.SHLL, x, y)
891    
892                 | T.LOAD(8, ea, mem) => load8(ea, mem)
893                 | T.LOAD(16, ea, mem) => load16(ea, mem)
894                 | T.LOAD(32, ea, mem) => load32(ea, mem)
895    
896                 | T.SX(32,8,T.LOAD(8,ea,mem)) => load8s(ea, mem)
897                 | T.SX(32,16,T.LOAD(16,ea,mem)) => load16s(ea, mem)
898                 | T.ZX(32,8,T.LOAD(8,ea,mem)) => load8(ea, mem)
899                 | T.ZX(32,16,T.LOAD(16,ea,mem)) => load16(ea, mem)
900    
901                 | T.COND(32, T.CMP(ty, cc, t1, t2), T.LI yes, T.LI no) =>
902                     setcc(ty, cc, t1, t2, toInt32 yes, toInt32 no)
903                 | T.COND(32, T.CMP(ty, cc, t1, t2), yes, no) =>
904                    (case !arch of (* PentiumPro and higher has CMOVcc *)
905                       Pentium => unknownExp exp
906                     | _ => cmovcc(ty, cc, t1, t2, yes, no)
907                    )
908                 | T.LET(s,e) => (doStmt s; doExpr(e, rd, an))
909                 | T.MARK(e, A.MARKREG f) => (f rd; doExpr(e, rd, an))
910                 | T.MARK(e, a) => doExpr(e, rd, a::an)
911                 | T.PRED(e,c) => doExpr(e, rd, A.CTRLUSE c::an)
912                 | T.REXT e =>
913                     ExtensionComp.compileRext (reducer()) {e=e, rd=rd, an=an}
914                   (* simplify and try again *)
915                 | exp => unknownExp exp
916              end (* doExpr *)
917    
918              (* generate an expression and return its result register
919               * If rewritePseudo is on, the result is guaranteed to be in a
920               * non memReg register
921               *)
922          and expr(exp as T.REG(_, rd)) =
923              if isMemReg rd then genExpr exp else rd
924            | expr exp = genExpr exp
925    
926          and genExpr exp =
927              let val rd = newReg() in doExpr(exp, rd, []); rd end
928    
929             (* Compare an expression with zero.
930              * On the x86, TEST is superior to AND for doing the same thing,
931              * since it doesn't need to write out the result in a register.
932              *)
933         and cmpWithZero(cc as (T.EQ | T.NE), e as T.ANDB(ty, a, b), an) =
934                (case ty of
935                   8  => test(I.TESTB, a, b, an)
936                 | 16 => test(I.TESTW, a, b, an)
937                 | 32 => test(I.TESTL, a, b, an)
938                 | _  => doExpr(e, newReg(), an);
939                 cc)
940            | cmpWithZero(cc, e, an) =
941              let val e =
942                    case e of (* hack to disable the lea optimization XXX *)
943                      T.ADD(_, a, b) => T.ADD(0, a, b)
944                    | e => e
945              in  doExpr(e, newReg(), an); cc end
946    
947              (* Emit a test.
948               *   The available modes are
949               *      r/m, r
950               *      r/m, imm
951               * On selecting the right instruction: TESTL/TESTW/TESTB.
952               * When anding an operand with a constant
953               * that fits within 8 (or 16) bits, it is possible to use TESTB,
954               * (or TESTW) instead of TESTL.   Because x86 is little endian,
955               * this works for memory operands too.  However, with TESTB, it is
956               * not possible to use registers other than
957               * AL, CL, BL, DL, and AH, CH, BH, DH.  So, the best way is to
958               * perform register allocation first, and if the operand registers
959               * are one of EAX, ECX, EBX, or EDX, replace the TESTL instruction
960               * by TESTB.
961               *)
962          and test(testopcode, a, b, an) =
963              let val (_, opnd1, opnd2) = commuteComparison(T.EQ, true, a, b)
964                  (* translate r, r/m => r/m, r *)
965                  val (opnd1, opnd2) =
966                       if isMemOpnd opnd2 then (opnd2, opnd1) else (opnd1, opnd2)
967              in  mark(testopcode{lsrc=opnd1, rsrc=opnd2}, an)
968              end
969    
970              (* %eflags <- src *)
971          and moveToEflags src =
972              if CB.sameColor(src, C.eflags) then ()
973              else (move(I.Direct src, eax); emit(I.LAHF))
974    
975              (* dst <- %eflags *)
976          and moveFromEflags dst =
977              if CB.sameColor(dst, C.eflags) then ()
978              else (emit(I.SAHF); move(eax, I.Direct dst))
979    
980             (* generate a condition code expression
981              * The zero is for setting the condition code!
982              * I have no idea why this is used.
983              *)
984          and doCCexpr(T.CMP(ty, cc, t1, t2), rd, an) =
985              (cmp(false, ty, cc, t1, t2, an);
986               moveFromEflags rd
987              )
988            | doCCexpr(T.CC(cond,rs), rd, an) =
989              if CB.sameColor(rs,C.eflags) orelse CB.sameColor(rd,C.eflags) then
990                 (moveToEflags rs; moveFromEflags rd)
991              else
992                 move'(I.Direct rs, I.Direct rd, an)
993            | doCCexpr(T.CCMARK(e,A.MARKREG f),rd,an) = (f rd; doCCexpr(e,rd,an))
994            | doCCexpr(T.CCMARK(e,a), rd, an) = doCCexpr(e,rd,a::an)
995            | doCCexpr(T.CCEXT e, cd, an) =
996               ExtensionComp.compileCCext (reducer()) {e=e, ccd=cd, an=an}
997            | doCCexpr _ = error "doCCexpr"
998    
999         and ccExpr e = error "ccExpr"
1000    
1001              (* generate a comparison and sets the condition code;
1002               * return the actual cc used.  If the flag swapable is true,
1003               * we can also reorder the operands.
1004               *)
1005          and cmp(swapable, ty, cc, t1, t2, an) =
1006                   (* == and <> can be always be reordered *)
1007              let val swapable = swapable orelse cc = T.EQ orelse cc = T.NE
1008              in (* Sometimes the comparison is not necessary because
1009                  * the bits are already set!
1010                  *)
1011                 if isZero t1 andalso setZeroBit2 t2 then
1012                     if swapable then
1013                        cmpWithZero(T.Basis.swapCond cc, t2, an)
1014                     else (* can't reorder the comparison! *)
1015                        genCmp(ty, false, cc, t1, t2, an)
1016                 else if isZero t2 andalso setZeroBit2 t1 then
1017                    cmpWithZero(cc, t1, an)
1018                 else genCmp(ty, swapable, cc, t1, t2, an)
1019              end
1020    
1021              (* Give a and b which are the operands to a comparison (or test)
1022               * Return the appropriate condition code and operands.
1023               *   The available modes are:
1024               *        r/m, imm
1025               *        r/m, r
1026               *        r,   r/m
1027               *)
1028          and commuteComparison(cc, swapable, a, b) =
1029              let val (opnd1, opnd2) = (operand a, operand b)
1030              in  (* Try to fold in the operands whenever possible *)
1031                  case (isImmediate opnd1, isImmediate opnd2) of
1032                    (true, true) => (cc, moveToReg opnd1, opnd2)
1033                  | (true, false) =>
1034                       if swapable then (T.Basis.swapCond cc, opnd2, opnd1)
1035                       else (cc, moveToReg opnd1, opnd2)
1036                  | (false, true) => (cc, opnd1, opnd2)
1037                  | (false, false) =>
1038                     (case (opnd1, opnd2) of
1039                        (_, I.Direct _) => (cc, opnd1, opnd2)
1040                      | (I.Direct _, _) => (cc, opnd1, opnd2)
1041                      | (_, _)          => (cc, moveToReg opnd1, opnd2)
1042                     )
1043              end
1044    
1045              (* generate a real comparison; return the real cc used *)
1046          and genCmp(ty, swapable, cc, a, b, an) =
1047              let val (cc, opnd1, opnd2) = commuteComparison(cc, swapable, a, b)
1048              in  mark(I.CMPL{lsrc=opnd1, rsrc=opnd2}, an); cc
1049              end
1050    
1051              (* generate code for jumps *)
1052          and jmp(lexp as T.LABEL lab, labs, an) =
1053                 mark(I.JMP(I.ImmedLabel lexp, [lab]), an)
1054            | jmp(T.LABEXP le, labs, an) = mark(I.JMP(I.ImmedLabel le, labs), an)
1055            | jmp(ea, labs, an)          = mark(I.JMP(operand ea, labs), an)
1056    
1057           (* convert mlrisc to cellset:
1058            *)
1059           and cellset mlrisc =
1060               let val addCCReg = CB.CellSet.add
1061                   fun g([],acc) = acc
1062                     | g(T.GPR(T.REG(_,r))::regs,acc)  = g(regs,C.addReg(r,acc))
1063                     | g(T.FPR(T.FREG(_,f))::regs,acc) = g(regs,C.addFreg(f,acc))
1064                     | g(T.CCR(T.CC(_,cc))::regs,acc)  = g(regs,addCCReg(cc,acc))
1065                     | g(T.CCR(T.FCC(_,cc))::regs,acc)  = g(regs,addCCReg(cc,acc))
1066                     | g(_::regs, acc) = g(regs, acc)
1067               in  g(mlrisc, C.empty) end
1068    
1069              (* generate code for calls *)
1070          and call(ea, flow, def, use, mem, cutsTo, an, pops) =
1071          let fun return(set, []) = set
1072                | return(set, a::an) =
1073                  case #peek A.RETURN_ARG a of
1074                    SOME r => return(CB.CellSet.add(r, set), an)
1075                  | NONE => return(set, an)
1076          in
1077              mark(I.CALL{opnd=operand ea,defs=cellset(def),uses=cellset(use),
1078                          return=return(C.empty,an),cutsTo=cutsTo,mem=mem,
1079                          pops=pops},an)
1080          end
1081    
1082              (* generate code for integer stores; first move data to %eax
1083               * This is mainly because we can't allocate to registers like
1084               * ah, dl, dx etc.
1085               *)
1086          and genStore(mvOp, ea, d, mem, an) =
1087              let val src =
1088                     case immedOrReg(operand d) of
1089                         src as I.Direct r =>
1090                           if CB.sameColor(r,C.eax)
1091                           then src else (move(src, eax); eax)
1092                       | src => src
1093              in  mark(I.MOVE{mvOp=mvOp, src=src, dst=address(ea,mem)},an)
1094              end
1095    
1096              (* generate code for 8-bit integer stores *)
1097              (* movb has to use %eax as source. Stupid x86! *)
1098          and store8(ea, d, mem, an) = genStore(I.MOVB, ea, d, mem, an)
1099          and store16(ea, d, mem, an) =
1100            mark(I.MOVE{mvOp=I.MOVW, src=immedOrReg(operand d), dst=address(ea, mem)}, an)
1101          and store32(ea, d, mem, an) =
1102                move'(immedOrReg(operand d), address(ea, mem), an)
1103    
1104              (* generate code for branching *)
1105          and branch(T.CMP(ty, cc, t1, t2), lab, an) =
1106               (* allow reordering of operands *)
1107               let val cc = cmp(true, ty, cc, t1, t2, [])
1108               in  mark(I.JCC{cond=cond cc, opnd=immedLabel lab}, an) end
1109            | branch(T.FCMP(fty, fcc, t1, t2), lab, an) =
1110               fbranch(fty, fcc, t1, t2, lab, an)
1111            | branch(ccexp, lab, an) =
1112               (doCCexpr(ccexp, C.eflags, []);
1113                mark(I.JCC{cond=cond(Gen.condOf ccexp), opnd=immedLabel lab}, an)
1114               )
1115    
1116              (* generate code for floating point compare and branch *)
1117          and fbranch(fty, fcc, t1, t2, lab, an) =
1118              let fun ignoreOrder (T.FREG _) = true
1119                    | ignoreOrder (T.FLOAD _) = true
1120                    | ignoreOrder (T.FMARK(e,_)) = ignoreOrder e
1121                    | ignoreOrder _ = false
1122    
1123                  fun compare'() = (* Sethi-Ullman style *)
1124                      (if ignoreOrder t1 orelse ignoreOrder t2 then
1125                            (reduceFexp(fty, t2, []); reduceFexp(fty, t1, []))
1126                       else (reduceFexp(fty, t1, []); reduceFexp(fty, t2, []);
1127                             emit(I.FXCH{opnd=C.ST(1)}));
1128                       emit(I.FUCOMPP);
1129                       fcc
1130                      )
1131    
1132                  fun compare''() =
1133                          (* direct style *)
1134                          (* Try to make lsrc the memory operand *)
1135                      let val lsrc = foperand(fty, t1)
1136                          val rsrc = foperand(fty, t2)
1137                          val fsize = fsize fty
1138                          fun cmp(lsrc, rsrc, fcc) =
1139                              (emit(I.FCMP{fsize=fsize,lsrc=lsrc,rsrc=rsrc}); fcc)
1140                      in  case (lsrc, rsrc) of
1141                             (I.FPR _, I.FPR _) => cmp(lsrc, rsrc, fcc)
1142                           | (I.FPR _, mem) => cmp(mem,lsrc,T.Basis.swapFcond fcc)
1143                           | (mem, I.FPR _) => cmp(lsrc, rsrc, fcc)
1144                           | (lsrc, rsrc) => (* can't be both memory! *)
1145                             let val ftmpR = newFreg()
1146                                 val ftmp  = I.FPR ftmpR
1147                             in  emit(I.FMOVE{fsize=fsize,src=rsrc,dst=ftmp});
1148                                 cmp(lsrc, ftmp, fcc)
1149                             end
1150          end          end
1151    
1152      val labels = suNumbering(fexp, LEFT)                fun compare() =
1153    in gencode(fexp, labels)                    if enableFastFPMode andalso !fast_floating_point
1154                      then compare''() else compare'()
1155    
1156                  fun andil i = emit(I.BINARY{binOp=I.ANDL,src=I.Immed(i),dst=eax})
1157                  fun testil i = emit(I.TESTL{lsrc=eax,rsrc=I.Immed(i)})
1158                  fun xoril i = emit(I.BINARY{binOp=I.XORL,src=I.Immed(i),dst=eax})
1159                  fun cmpil i = emit(I.CMPL{rsrc=I.Immed(i), lsrc=eax})
1160                  fun j(cc, lab) = mark(I.JCC{cond=cc, opnd=immedLabel lab},an)
1161                  fun sahf() = emit(I.SAHF)
1162                  fun branch(fcc) =
1163                      case fcc
1164                      of T.==   => (andil 0x4400; xoril 0x4000; j(I.EQ, lab))
1165                       | T.?<>  => (andil 0x4400; xoril 0x4000; j(I.NE, lab))
1166                       | T.?    => (sahf(); j(I.P,lab))
1167                       | T.<=>  => (sahf(); j(I.NP,lab))
1168                       | T.>    => (testil 0x4500;  j(I.EQ,lab))
1169                       | T.?<=  => (testil 0x4500;  j(I.NE,lab))
1170                       | T.>=   => (testil 0x500; j(I.EQ,lab))
1171                       | T.?<   => (testil 0x500; j(I.NE,lab))
1172                       | T.<    => (andil 0x4500; cmpil 0x100; j(I.EQ,lab))
1173                       | T.?>=  => (andil 0x4500; cmpil 0x100; j(I.NE,lab))
1174                       | T.<=   => (andil 0x4100; cmpil 0x100; j(I.EQ,lab);
1175                                    cmpil 0x4000; j(I.EQ,lab))
1176                       | T.?>   => (sahf(); j(I.P,lab); testil 0x4100; j(I.EQ,lab))
1177                       | T.<>   => (testil 0x4400; j(I.EQ,lab))
1178                       | T.?=   => (testil 0x4400; j(I.NE,lab))
1179                       | _      => error "fbranch"
1180                     (*esac*)
1181                  val fcc = compare()
1182              in  emit I.FNSTSW;
1183                  branch(fcc)
1184              end
1185    
1186          (*========================================================
1187           * Floating point code generation starts here.
1188           * Some generic fp routines first.
1189           *========================================================*)
1190    
1191           (* Can this tree be folded into the src operand of a floating point
1192            * operations?
1193            *)
1194          and foldableFexp(T.FREG _) = true
1195            | foldableFexp(T.FLOAD _) = true
1196            | foldableFexp(T.CVTI2F(_, (16 | 32), _)) = true
1197            | foldableFexp(T.CVTF2F(_, _, t)) = foldableFexp t
1198            | foldableFexp(T.FMARK(t, _)) = foldableFexp t
1199            | foldableFexp _ = false
1200    
1201            (* Move integer e of size ty into a memory location.
1202             * Returns a quadruple:
1203             *  (INTEGER,return ty,effect address of memory location,cleanup code)
1204             *)
1205          and convertIntToFloat(ty, e) =
1206              let val opnd = operand e
1207              in  if isMemOpnd opnd andalso (ty = 16 orelse ty = 32)
1208                  then (INTEGER, ty, opnd, [])
1209                  else
1210                    let val {instrs, tempMem, cleanup} =
1211                            cvti2f{ty=ty, src=opnd, an=getAnnotations()}
1212                    in  emits instrs;
1213                        (INTEGER, 32, tempMem, cleanup)
1214                    end
1215              end
1216    
1217          (*========================================================
1218           * Sethi-Ullman based floating point code generation as
1219           * implemented by Lal
1220           *========================================================*)
1221    
1222          and fld(32, opnd) = I.FLDS opnd
1223            | fld(64, opnd) = I.FLDL opnd
1224            | fld(80, opnd) = I.FLDT opnd
1225            | fld _         = error "fld"
1226    
1227          and fild(16, opnd) = I.FILD opnd
1228            | fild(32, opnd) = I.FILDL opnd
1229            | fild(64, opnd) = I.FILDLL opnd
1230            | fild _         = error "fild"
1231    
1232          and fxld(INTEGER, ty, opnd) = fild(ty, opnd)
1233            | fxld(REAL, fty, opnd) = fld(fty, opnd)
1234    
1235          and fstp(32, opnd) = I.FSTPS opnd
1236            | fstp(64, opnd) = I.FSTPL opnd
1237            | fstp(80, opnd) = I.FSTPT opnd
1238            | fstp _         = error "fstp"
1239    
1240              (* generate code for floating point stores *)
1241          and fstore'(fty, ea, d, mem, an) =
1242              (case d of
1243                 T.FREG(fty, fs) => emit(fld(fty, I.FDirect fs))
1244               | _ => reduceFexp(fty, d, []);
1245               mark(fstp(fty, address(ea, mem)), an)
1246              )
1247    
1248              (* generate code for floating point loads *)
1249          and fload'(fty, ea, mem, fd, an) =
1250                let val ea = address(ea, mem)
1251                in  mark(fld(fty, ea), an);
1252                    if CB.sameColor(fd,ST0) then ()
1253                    else emit(fstp(fty, I.FDirect fd))
1254                end
1255    
1256          and fexpr' e = (reduceFexp(64, e, []); C.ST(0))
1257    
1258              (* generate floating point expression and put the result in fd *)
1259          and doFexpr'(fty, T.FREG(_, fs), fd, an) =
1260                (if CB.sameColor(fs,fd) then ()
1261                 else mark(I.FCOPY{dst=[fd], src=[fs], tmp=NONE}, an)
1262                )
1263            | doFexpr'(_, T.FLOAD(fty, ea, mem), fd, an) =
1264                fload'(fty, ea, mem, fd, an)
1265            | doFexpr'(fty, T.FEXT fexp, fd, an) =
1266                (ExtensionComp.compileFext (reducer()) {e=fexp, fd=fd, an=an};
1267                 if CB.sameColor(fd,ST0) then () else emit(fstp(fty, I.FDirect fd))
1268                )
1269            | doFexpr'(fty, e, fd, an) =
1270                (reduceFexp(fty, e, []);
1271                 if CB.sameColor(fd,ST0) then ()
1272                 else mark(fstp(fty, I.FDirect fd), an)
1273                )
1274    
1275              (*
1276               * Generate floating point expression using Sethi-Ullman's scheme:
1277               * This function evaluates a floating point expression,
1278               * and put result in %ST(0).
1279               *)
1280          and reduceFexp(fty, fexp, an)  =
1281              let val ST = I.ST(C.ST 0)
1282                  val ST1 = I.ST(C.ST 1)
1283                  val cleanupCode = ref [] : I.instruction list ref
1284    
1285                  datatype su_tree =
1286                    LEAF of int * T.fexp * ans
1287                  | BINARY of int * T.fty * fbinop * su_tree * su_tree * ans
1288                  | UNARY of int * T.fty * I.funOp * su_tree * ans
1289                  and fbinop = FADD | FSUB | FMUL | FDIV
1290                             | FIADD | FISUB | FIMUL | FIDIV
1291                  withtype ans = Annotations.annotations
1292    
1293                  fun label(LEAF(n, _, _)) = n
1294                    | label(BINARY(n, _, _, _, _, _)) = n
1295                    | label(UNARY(n, _, _, _, _)) = n
1296    
1297                  fun annotate(LEAF(n, x, an), a)  = LEAF(n,x,a::an)
1298                    | annotate(BINARY(n,t,b,x,y,an), a) = BINARY(n,t,b,x,y,a::an)
1299                    | annotate(UNARY(n,t,u,x,an), a) = UNARY(n,t,u,x,a::an)
1300    
1301                  (* Generate expression tree with sethi-ullman numbers *)
1302                  fun su(e as T.FREG _)       = LEAF(1, e, [])
1303                    | su(e as T.FLOAD _)      = LEAF(1, e, [])
1304                    | su(e as T.CVTI2F _)     = LEAF(1, e, [])
1305                    | su(T.CVTF2F(_, _, t))   = su t
1306                    | su(T.FMARK(t, a))       = annotate(su t, a)
1307                    | su(T.FABS(fty, t))      = suUnary(fty, I.FABS, t)
1308                    | su(T.FNEG(fty, t))      = suUnary(fty, I.FCHS, t)
1309                    | su(T.FSQRT(fty, t))     = suUnary(fty, I.FSQRT, t)
1310                    | su(T.FADD(fty, t1, t2)) = suComBinary(fty,FADD,FIADD,t1,t2)
1311                    | su(T.FMUL(fty, t1, t2)) = suComBinary(fty,FMUL,FIMUL,t1,t2)
1312                    | su(T.FSUB(fty, t1, t2)) = suBinary(fty,FSUB,FISUB,t1,t2)
1313                    | su(T.FDIV(fty, t1, t2)) = suBinary(fty,FDIV,FIDIV,t1,t2)
1314                    | su _ = error "su"
1315    
1316                  (* Try to fold the the memory operand or integer conversion *)
1317                  and suFold(e as T.FREG _) = (LEAF(0, e, []), false)
1318                    | suFold(e as T.FLOAD _) = (LEAF(0, e, []), false)
1319                    | suFold(e as T.CVTI2F(_,(16 | 32),_)) = (LEAF(0, e, []), true)
1320                    | suFold(T.CVTF2F(_, _, t)) = suFold t
1321                    | suFold(T.FMARK(t, a)) =
1322                      let val (t, integer) = suFold t
1323                      in  (annotate(t, a), integer) end
1324                    | suFold e = (su e, false)
1325    
1326                  (* Form unary tree *)
1327                  and suUnary(fty, funary, t) =
1328                      let val t = su t
1329                      in  UNARY(label t, fty, funary, t, [])
1330                      end
1331    
1332                  (* Form binary tree *)
1333                  and suBinary(fty, binop, ibinop, t1, t2) =
1334                      let val t1 = su t1
1335                          val (t2, integer) = suFold t2
1336                          val n1 = label t1
1337                          val n2 = label t2
1338                          val n  = if n1=n2 then n1+1 else Int.max(n1,n2)
1339                          val myOp = if integer then ibinop else binop
1340                      in  BINARY(n, fty, myOp, t1, t2, [])
1341                      end
1342    
1343                  (* Try to fold in the operand if possible.
1344                   * This only applies to commutative operations.
1345                   *)
1346                  and suComBinary(fty, binop, ibinop, t1, t2) =
1347                      let val (t1, t2) = if foldableFexp t2
1348                                         then (t1, t2) else (t2, t1)
1349                      in  suBinary(fty, binop, ibinop, t1, t2) end
1350    
1351                  and sameTree(LEAF(_, T.FREG(t1,f1), []),
1352                               LEAF(_, T.FREG(t2,f2), [])) =
1353                            t1 = t2 andalso CB.sameColor(f1,f2)
1354                    | sameTree _ = false
1355    
1356                  (* Traverse tree and generate code *)
1357                  fun gencode(LEAF(_, t, an)) = mark(fxld(leafEA t), an)
1358                    | gencode(BINARY(_, _, binop, x, t2 as LEAF(0, y, a1), a2)) =
1359                      let val _          = gencode x
1360                          val (_, fty, src) = leafEA y
1361                          fun gen(code) = mark(code, a1 @ a2)
1362                          fun binary(oper32, oper64) =
1363                              if sameTree(x, t2) then
1364                                 gen(I.FBINARY{binOp=oper64, src=ST, dst=ST})
1365                              else
1366                                 let val oper =
1367                                       if isMemOpnd src then
1368                                          case fty of
1369                                            32 => oper32
1370                                          | 64 => oper64
1371                                          | _  => error "gencode: BINARY"
1372                                       else oper64
1373                                 in gen(I.FBINARY{binOp=oper, src=src, dst=ST}) end
1374                          fun ibinary(oper16, oper32) =
1375                              let val oper = case fty of
1376                                               16 => oper16
1377                                             | 32 => oper32
1378                                             | _  => error "gencode: IBINARY"
1379                              in  gen(I.FIBINARY{binOp=oper, src=src}) end
1380                      in  case binop of
1381                            FADD => binary(I.FADDS, I.FADDL)
1382                          | FSUB => binary(I.FDIVS, I.FSUBL)
1383                          | FMUL => binary(I.FMULS, I.FMULL)
1384                          | FDIV => binary(I.FDIVS, I.FDIVL)
1385                          | FIADD => ibinary(I.FIADDS, I.FIADDL)
1386                          | FISUB => ibinary(I.FIDIVS, I.FISUBL)
1387                          | FIMUL => ibinary(I.FIMULS, I.FIMULL)
1388                          | FIDIV => ibinary(I.FIDIVS, I.FIDIVL)
1389                      end
1390                    | gencode(BINARY(_, fty, binop, t1, t2, an)) =
1391                      let fun doit(t1, t2, oper, operP, operRP) =
1392                          let (* oper[P] =>  ST(1) := ST oper ST(1); [pop]
1393                               * operR[P] => ST(1) := ST(1) oper ST; [pop]
1394                               *)
1395                               val n1 = label t1
1396                               val n2 = label t2
1397                          in if n1 < n2 andalso n1 <= 7 then
1398                               (gencode t2;
1399                                gencode t1;
1400                                mark(I.FBINARY{binOp=operP, src=ST, dst=ST1}, an))
1401                             else if n2 <= n1 andalso n2 <= 7 then
1402                               (gencode t1;
1403                                gencode t2;
1404                                mark(I.FBINARY{binOp=operRP, src=ST, dst=ST1}, an))
1405                             else
1406                             let (* both labels > 7 *)
1407                                 val fs = I.FDirect(newFreg())
1408                             in  gencode t2;
1409                                 emit(fstp(fty, fs));
1410                                 gencode t1;
1411                                 mark(I.FBINARY{binOp=oper, src=fs, dst=ST}, an)
1412                             end
1413                         end
1414                      in case binop of
1415                           FADD => doit(t1,t2,I.FADDL,I.FADDP,I.FADDP)
1416                         | FMUL => doit(t1,t2,I.FMULL,I.FMULP,I.FMULP)
1417                         | FSUB => doit(t1,t2,I.FSUBL,I.FSUBP,I.FSUBRP)
1418                         | FDIV => doit(t1,t2,I.FDIVL,I.FDIVP,I.FDIVRP)
1419                         | _ => error "gencode.BINARY"
1420                      end
1421                    | gencode(UNARY(_, _, unaryOp, su, an)) =
1422                       (gencode(su); mark(I.FUNARY(unaryOp),an))
1423    
1424                  (* Generate code for a leaf.
1425                   * Returns the type and an effective address
1426                   *)
1427                  and leafEA(T.FREG(fty, f)) = (REAL, fty, I.FDirect f)
1428                    | leafEA(T.FLOAD(fty, ea, mem)) = (REAL, fty, address(ea, mem))
1429                    | leafEA(T.CVTI2F(_, 32, t)) = int2real(32, t)
1430                    | leafEA(T.CVTI2F(_, 16, t)) = int2real(16, t)
1431                    | leafEA(T.CVTI2F(_, 8, t))  = int2real(8, t)
1432                    | leafEA _ = error "leafEA"
1433    
1434                  and int2real(ty, e) =
1435                      let val (_, ty, ea, cleanup) = convertIntToFloat(ty, e)
1436                      in  cleanupCode := !cleanupCode @ cleanup;
1437                          (INTEGER, ty, ea)
1438                      end
1439    
1440             in  gencode(su fexp);
1441                 emits(!cleanupCode)
1442    end (*reduceFexp*)    end (*reduceFexp*)
1443    
1444    fun mltreeComp mltree = let         (*========================================================
1445      fun mltc(T.PSEUDO_OP pOp)     = F.pseudoOp pOp          * This section generates 3-address style floating
1446        | mltc(T.DEFINELABEL lab)   = F.defineLabel lab          * point code.
1447        | mltc(T.ENTRYLABEL lab)    = F.entryLabel lab          *========================================================*)
1448        | mltc(T.ORDERED mlts)      = F.ordered mlts  
1449        | mltc(T.BEGINCLUSTER)      = (F.beginCluster(); trapLabel := NONE)        and isize 16 = I.I16
1450        | mltc(T.CODE stms)         = app reduceStm stms          | isize 32 = I.I32
1451        | mltc(T.BLOCK_NAME name)   = F.blockName name          | isize _  = error "isize"
1452        | mltc(T.ENDCLUSTER regmap) =  
1453          and fstore''(fty, ea, d, mem, an) =
1454              (floatingPointUsed := true;
1455               mark(I.FMOVE{fsize=fsize fty, dst=address(ea,mem),
1456                            src=foperand(fty, d)},
1457                    an)
1458              )
1459    
1460          and fload''(fty, ea, mem, d, an) =
1461              (floatingPointUsed := true;
1462               mark(I.FMOVE{fsize=fsize fty, src=address(ea,mem),
1463                            dst=RealReg d}, an)
1464              )
1465    
1466          and fiload''(ity, ea, d, an) =
1467              (floatingPointUsed := true;
1468               mark(I.FILOAD{isize=isize ity, ea=ea, dst=RealReg d}, an)
1469              )
1470    
1471          and fexpr''(e as T.FREG(_,f)) =
1472              if isFMemReg f then transFexpr e else f
1473            | fexpr'' e = transFexpr e
1474    
1475          and transFexpr e =
1476              let val fd = newFreg() in doFexpr''(64, e, fd, []); fd end
1477    
1478             (*
1479              * Process a floating point operand.  Put operand in register
1480              * when possible.  The operand should match the given fty.
1481              *)
1482          and foperand(fty, e as T.FREG(fty', f)) =
1483                 if fty = fty' then RealReg f else I.FPR(fexpr'' e)
1484            | foperand(fty, T.CVTF2F(_, _, e)) =
1485                 foperand(fty, e) (* nop on the x86 *)
1486            | foperand(fty, e as T.FLOAD(fty', ea, mem)) =
1487                 (* fold operand when the precison matches *)
1488                 if fty = fty' then address(ea, mem) else I.FPR(fexpr'' e)
1489            | foperand(fty, e) = I.FPR(fexpr'' e)
1490    
1491             (*
1492              * Process a floating point operand.
1493              * Try to fold in a memory operand or conversion from an integer.
1494              *)
1495          and fioperand(T.FREG(fty,f)) = (REAL, fty, RealReg f, [])
1496            | fioperand(T.FLOAD(fty, ea, mem)) =
1497                 (REAL, fty, address(ea, mem), [])
1498            | fioperand(T.CVTF2F(_, _, e)) = fioperand(e) (* nop on the x86 *)
1499            | fioperand(T.CVTI2F(_, ty, e)) = convertIntToFloat(ty, e)
1500            | fioperand(T.FMARK(e,an)) = fioperand(e) (* XXX *)
1501            | fioperand(e) = (REAL, 64, I.FPR(fexpr'' e), [])
1502    
1503              (* Generate binary operator.  Since the real binary operators
1504               * does not take memory as destination, we also ensure this
1505               * does not happen.
1506               *)
1507          and fbinop(targetFty,
1508                     binOp, binOpR, ibinOp, ibinOpR, lsrc, rsrc, fd, an) =
1509                  (* Put the mem operand in rsrc *)
1510              let val _ = floatingPointUsed := true;
1511                  fun isMemOpnd(T.FREG(_, f)) = isFMemReg f
1512                    | isMemOpnd(T.FLOAD _) = true
1513                    | isMemOpnd(T.CVTI2F(_, (16 | 32), _)) = true
1514                    | isMemOpnd(T.CVTF2F(_, _, t)) = isMemOpnd t
1515                    | isMemOpnd(T.FMARK(t, _)) = isMemOpnd t
1516                    | isMemOpnd _ = false
1517                  val (binOp, ibinOp, lsrc, rsrc) =
1518                      if isMemOpnd lsrc then (binOpR, ibinOpR, rsrc, lsrc)
1519                      else (binOp, ibinOp, lsrc, rsrc)
1520                  val lsrc = foperand(targetFty, lsrc)
1521                  val (kind, fty, rsrc, code) = fioperand(rsrc)
1522                  fun dstMustBeFreg f =
1523                      if targetFty <> 64 then
1524                      let val tmpR = newFreg()
1525                          val tmp  = I.FPR tmpR
1526                      in  mark(f tmp, an);
1527                          emit(I.FMOVE{fsize=fsize targetFty,
1528                                       src=tmp, dst=RealReg fd})
1529                      end
1530                      else mark(f(RealReg fd), an)
1531              in  case kind of
1532                    REAL =>
1533                      dstMustBeFreg(fn dst =>
1534                                       I.FBINOP{fsize=fsize fty, binOp=binOp,
1535                                                lsrc=lsrc, rsrc=rsrc, dst=dst})
1536                  | INTEGER =>
1537                      (dstMustBeFreg(fn dst =>
1538                                        I.FIBINOP{isize=isize fty, binOp=ibinOp,
1539                                                  lsrc=lsrc, rsrc=rsrc, dst=dst});
1540                       emits code
1541                      )
1542              end
1543    
1544          and funop(fty, unOp, src, fd, an) =
1545              let val src = foperand(fty, src)
1546              in  mark(I.FUNOP{fsize=fsize fty,
1547                               unOp=unOp, src=src, dst=RealReg fd},an)
1548              end
1549    
1550          and doFexpr''(fty, e, fd, an) =
1551              case e of
1552                T.FREG(_,fs) => if CB.sameColor(fs,fd) then ()
1553                                else fcopy''(fty, [fd], [fs], an)
1554                (* Stupid x86 does everything as 80-bits internally. *)
1555    
1556                (* Binary operators *)
1557              | T.FADD(_, a, b) => fbinop(fty,
1558                                          I.FADDL, I.FADDL, I.FIADDL, I.FIADDL,
1559                                          a, b, fd, an)
1560              | T.FSUB(_, a, b) => fbinop(fty,
1561                                          I.FSUBL, I.FSUBRL, I.FISUBL, I.FISUBRL,
1562                                          a, b, fd, an)
1563              | T.FMUL(_, a, b) => fbinop(fty,
1564                                          I.FMULL, I.FMULL, I.FIMULL, I.FIMULL,
1565                                          a, b, fd, an)
1566              | T.FDIV(_, a, b) => fbinop(fty,
1567                                          I.FDIVL, I.FDIVRL, I.FIDIVL, I.FIDIVRL,
1568                                          a, b, fd, an)
1569    
1570                (* Unary operators *)
1571              | T.FNEG(_, a) => funop(fty, I.FCHS, a, fd, an)
1572              | T.FABS(_, a) => funop(fty, I.FABS, a, fd, an)
1573              | T.FSQRT(_, a) => funop(fty, I.FSQRT, a, fd, an)
1574    
1575                (* Load *)
1576              | T.FLOAD(fty,ea,mem) => fload''(fty, ea, mem, fd, an)
1577    
1578                (* Type conversions *)
1579              | T.CVTF2F(_, _, e) => doFexpr''(fty, e, fd, an)
1580              | T.CVTI2F(_, ty, e) =>
1581                let val (_, ty, ea, cleanup) = convertIntToFloat(ty, e)
1582                in  fiload''(ty, ea, fd, an);
1583                    emits cleanup
1584                end
1585    
1586              | T.FMARK(e,A.MARKREG f) => (f fd; doFexpr''(fty, e, fd, an))
1587              | T.FMARK(e, a) => doFexpr''(fty, e, fd, a::an)
1588              | T.FPRED(e, c) => doFexpr''(fty, e, fd, A.CTRLUSE c::an)
1589              | T.FEXT fexp =>
1590                 ExtensionComp.compileFext (reducer()) {e=fexp, fd=fd, an=an}
1591              | _ => error("doFexpr''")
1592    
1593           (*========================================================
1594            * Tie the two styles of fp code generation together
1595            *========================================================*)
1596          and fstore(fty, ea, d, mem, an) =
1597              if enableFastFPMode andalso !fast_floating_point
1598              then fstore''(fty, ea, d, mem, an)
1599              else fstore'(fty, ea, d, mem, an)
1600          and fload(fty, ea, d, mem, an) =
1601              if enableFastFPMode andalso !fast_floating_point
1602              then fload''(fty, ea, d, mem, an)
1603              else fload'(fty, ea, d, mem, an)
1604          and fexpr e =
1605              if enableFastFPMode andalso !fast_floating_point
1606              then fexpr'' e else fexpr' e
1607          and doFexpr(fty, e, fd, an) =
1608              if enableFastFPMode andalso !fast_floating_point
1609              then doFexpr''(fty, e, fd, an)
1610              else doFexpr'(fty, e, fd, an)
1611    
1612          (*================================================================
1613           * Optimizations for x := x op y
1614           * Special optimizations:
1615           * Generate a binary operator, result must in memory.
1616           * The source must not be in memory
1617           *================================================================*)
1618          and binaryMem(binOp, src, dst, mem, an) =
1619              mark(I.BINARY{binOp=binOp, src=immedOrReg(operand src),
1620                            dst=address(dst,mem)}, an)
1621          and unaryMem(unOp, opnd, mem, an) =
1622              mark(I.UNARY{unOp=unOp, opnd=address(opnd,mem)}, an)
1623    
1624          and isOne(T.LI n) = n = one
1625            | isOne _ = false
1626    
1627          (*
1628           * Perform optimizations based on recognizing
1629           *    x := x op y    or
1630           *    x := y op x
1631           * first.
1632           *)
1633          and store(ty, ea, d, mem, an,
1634                    {INC,DEC,ADD,SUB,NOT,NEG,SHL,SHR,SAR,OR,AND,XOR},
1635                    doStore
1636                   ) =
1637              let fun default() = doStore(ea, d, mem, an)
1638                  fun binary1(t, t', unary, binary, ea', x) =
1639                      if t = ty andalso t' = ty then
1640                         if MLTreeUtils.eqRexp(ea, ea') then
1641                            if isOne x then unaryMem(unary, ea, mem, an)
1642                            else binaryMem(binary, x, ea, mem, an)
1643                          else default()
1644                      else default()
1645                  fun unary(t,unOp, ea') =
1646                      if t = ty andalso MLTreeUtils.eqRexp(ea, ea') then
1647                         unaryMem(unOp, ea, mem, an)
1648                      else default()
1649                  fun binary(t,t',binOp,ea',x) =
1650                      if t = ty andalso t' = ty andalso
1651                         MLTreeUtils.eqRexp(ea, ea') then
1652                          binaryMem(binOp, x, ea, mem, an)
1653                      else default()
1654    
1655                  fun binaryCom1(t,unOp,binOp,x,y) =
1656                  if t = ty then
1657                  let fun again() =
1658                        case y of
1659                          T.LOAD(ty',ea',_) =>
1660                            if ty' = ty andalso MLTreeUtils.eqRexp(ea, ea') then
1661                               if isOne x then unaryMem(unOp, ea, mem, an)
1662                               else binaryMem(binOp,x,ea,mem,an)
1663                            else default()
1664                        | _ => default()
1665                  in  case x of
1666                        T.LOAD(ty',ea',_) =>
1667                          if ty' = ty andalso MLTreeUtils.eqRexp(ea, ea') then
1668                             if isOne y then unaryMem(unOp, ea, mem, an)
1669                             else binaryMem(binOp,y,ea,mem,an)
1670                          else again()
1671                      | _ => again()
1672                  end
1673                  else default()
1674    
1675                  fun binaryCom(t,binOp,x,y) =
1676                  if t = ty then
1677                  let fun again() =
1678                        case y of
1679                          T.LOAD(ty',ea',_) =>
1680                            if ty' = ty andalso MLTreeUtils.eqRexp(ea, ea') then
1681                               binaryMem(binOp,x,ea,mem,an)
1682                            else default()
1683                        | _ => default()
1684                  in  case x of
1685                        T.LOAD(ty',ea',_) =>
1686                          if ty' = ty andalso MLTreeUtils.eqRexp(ea, ea') then
1687                             binaryMem(binOp,y,ea,mem,an)
1688                          else again()
1689                      | _ => again()
1690                  end
1691                  else default()
1692    
1693              in  case d of
1694                    T.ADD(t,x,y) => binaryCom1(t,INC,ADD,x,y)
1695                  | T.SUB(t,T.LOAD(t',ea',_),x) => binary1(t,t',DEC,SUB,ea',x)
1696                  | T.ORB(t,x,y) => binaryCom(t,OR,x,y)
1697                  | T.ANDB(t,x,y) => binaryCom(t,AND,x,y)
1698                  | T.XORB(t,x,y) => binaryCom(t,XOR,x,y)
1699                  | T.SLL(t,T.LOAD(t',ea',_),x) => binary(t,t',SHL,ea',x)
1700                  | T.SRL(t,T.LOAD(t',ea',_),x) => binary(t,t',SHR,ea',x)
1701                  | T.SRA(t,T.LOAD(t',ea',_),x) => binary(t,t',SAR,ea',x)
1702                  | T.NEG(t,T.LOAD(t',ea',_)) => unary(t,NEG,ea')
1703                  | T.NOTB(t,T.LOAD(t',ea',_)) => unary(t,NOT,ea')
1704                  | _ => default()
1705              end (* store *)
1706    
1707              (* generate code for a statement *)
1708          and stmt(T.MV(_, rd, e), an) = doExpr(e, rd, an)
1709            | stmt(T.FMV(fty, fd, e), an) = doFexpr(fty, e, fd, an)
1710            | stmt(T.CCMV(ccd, e), an) = doCCexpr(e, ccd, an)
1711            | stmt(T.COPY(_, dst, src), an) = copy(dst, src, an)
1712            | stmt(T.FCOPY(fty, dst, src), an) = fcopy(fty, dst, src, an)
1713            | stmt(T.JMP(e, labs), an) = jmp(e, labs, an)
1714            | stmt(T.CALL{funct, targets, defs, uses, region, pops, ...}, an) =
1715                 call(funct,targets,defs,uses,region,[],an, pops)
1716            | stmt(T.FLOW_TO(T.CALL{funct, targets, defs, uses, region, pops, ...},
1717                             cutTo), an) =
1718                 call(funct,targets,defs,uses,region,cutTo,an, pops)
1719            | stmt(T.RET _, an) = mark(I.RET NONE, an)
1720            | stmt(T.STORE(8, ea, d, mem), an)  =
1721                 store(8, ea, d, mem, an, opcodes8, store8)
1722            | stmt(T.STORE(16, ea, d, mem), an) =
1723                 store(16, ea, d, mem, an, opcodes16, store16)
1724            | stmt(T.STORE(32, ea, d, mem), an) =
1725                 store(32, ea, d, mem, an, opcodes32, store32)
1726    
1727            | stmt(T.FSTORE(fty, ea, d, mem), an) = fstore(fty, ea, d, mem, an)
1728            | stmt(T.BCC(cc, lab), an) = branch(cc, lab, an)
1729            | stmt(T.DEFINE l, _) = defineLabel l
1730            | stmt(T.ANNOTATION(s, a), an) = stmt(s, a::an)
1731            | stmt(T.EXT s, an) =
1732                 ExtensionComp.compileSext (reducer()) {stm=s, an=an}
1733            | stmt(s, _) = doStmts(Gen.compileStm s)
1734    
1735          and doStmt s = stmt(s, [])
1736          and doStmts ss = app doStmt ss
1737    
1738          and beginCluster' _ =
1739             ((* Must be cleared by the client.
1740               * if rewriteMemReg then memRegsUsed := 0w0 else ();
1741               *)
1742              floatingPointUsed := false;
1743              trapLabel := NONE;
1744              beginCluster 0
1745             )
1746          and endCluster' a =
1747           (case !trapLabel           (case !trapLabel
1748            of NONE => ()            of NONE => ()
1749             | SOME lab => (F.defineLabel lab; emit(I.INTO))             | SOME(_, lab) => (defineLabel lab; emit(I.INTO))
1750            (*esac*);            (*esac*);
1751            F.endCluster regmap)            (* If floating point has been used allocate an extra
1752        | mltc(T.ESCAPEBLOCK regs)  = F.exitBlock regs             * register just in case we didn't use any explicit register
1753    in mltc mltree             *)
1754    end            if !floatingPointUsed then (newFreg(); ())
1755              else ();
1756              endCluster(a)
1757             )
1758    
1759          and reducer() =
1760              TS.REDUCER{reduceRexp    = expr,
1761                        reduceFexp    = fexpr,
1762                        reduceCCexp   = ccExpr,
1763                        reduceStm     = stmt,
1764                        operand       = operand,
1765                        reduceOperand = reduceOpnd,
1766                        addressOf     = fn e => address(e, I.Region.memory), (*XXX*)
1767                        emit          = emitInstruction o mark',
1768                        instrStream   = instrStream,
1769                        mltreeStream  = self()
1770                       }
1771    
1772          and self() =
1773              TS.S.STREAM
1774              {  beginCluster   = beginCluster',
1775                 endCluster     = endCluster',
1776                 emit           = doStmt,
1777                 pseudoOp       = pseudoOp,
1778                 defineLabel    = defineLabel,
1779                 entryLabel     = entryLabel,
1780                 comment        = comment,
1781                 annotation     = annotation,
1782                 getAnnotations = getAnnotations,
1783                 exitBlock      = fn mlrisc => exitBlock(cellset mlrisc)
1784              }
1785    
1786    val mlriscComp  = reduceStm    in  self()
1787  end  end
1788    
1789    end (* functor *)
1790    
1791    end (* local *)

Legend:
Removed from v.247  
changed lines
  Added in v.1003

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0