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

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

Legend:
Removed from v.545  
changed lines
  Added in v.1136

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