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

Legend:
Removed from v.429  
changed lines
  Added in v.744

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