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

SCM Repository

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

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

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

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

Legend:
Removed from v.498  
changed lines
  Added in v.889

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