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

SCM Repository

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

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

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

sml/branches/SMLNJ/src/MLRISC/x86/mltree/x86.sml revision 498, Tue Dec 7 15:44:50 1999 UTC sml/trunk/src/MLRISC/x86/mltree/x86.sml revision 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       structure ExtensionComp : MLTREE_EXTENSION_COMP
44         where I = X86Instr and T = X86MLTree
45       sharing X86MLTree.Region = X86Instr.Region       sharing X86MLTree.Region = X86Instr.Region
46       sharing X86MLTree.Constant = X86Instr.Constant       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,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
422      | cond T.GE = I.GE        | cond T.GEU = I.AE            end
     | cond T.GT = I.GT        | cond T.GTU = I.A  
423    
424   (* reduce an MLRISC statement tree *)        and reduceOpnd(I.Direct r) = r
425    and reduceStm(T.MV(_, rd, exp),an) =          | reduceOpnd opnd =
426        let fun mv src = mark(I.MOVE{mvOp=I.MOVL, src=src, dst=I.Direct rd},an)            let val dst = newReg()
427        in  case operandRd(exp, rd)            in  move(opnd, I.Direct dst); dst
428            of opnd as I.Direct rd' => if rd'=rd then () else mv opnd            end
429             | opnd => mv opnd  
430        end        (* ensure that the operand is either an immed or register *)
431      | reduceStm(T.FMV(_, fd, T.FREG(_,fs)),an) =        and immedOrReg(opnd as I.Displace _) = moveToReg opnd
432         if fs=fd then () else mark(I.COPY{dst=[fd], src=[fs], tmp=NONE},an)          | immedOrReg(opnd as I.Indexed _)  = moveToReg opnd
433      | reduceStm(T.FMV(_, fd, T.FLOAD(_, t, mem)),an) =          | immedOrReg(opnd as I.MemReg _)   = moveToReg opnd
434         (mark(I.FLD(ea(t,mem)),an); emit(I.FSTP(I.FDirect fd)))          | immedOrReg(opnd as I.LabelEA _)  = moveToReg opnd
435      | reduceStm(T.FMV(_, fd, e),an) =          | immedOrReg opnd  = opnd
436         (reduceFexp(e,an); emit(I.FSTP(I.FDirect fd)))  
437      | reduceStm(T.CCMV(0, exp),an) = reduceCC(exp, 0, an)        and isImmediate(I.Immed _) = true
438      | reduceStm(T.CCMV _,_) = error "reduceStm: CCMV"          | isImmediate(I.ImmedLabel _) = true
439      | reduceStm(T.COPY(_, dst as [_], src),an) =          | isImmediate _ = false
440          mark(I.COPY{dst=dst, src=src, tmp=NONE},an)  
441      | reduceStm(T.COPY(_, dst, src),an) =        and regOrMem opnd = if isImmediate opnd then moveToReg opnd else opnd
442          mark(I.COPY{dst=dst, src=src, tmp=SOME(I.Direct(newReg()))},an)  
443      | reduceStm(T.FCOPY(_, dst, src),an) =        and isMemOpnd opnd =
444          mark(I.FCOPY{dst=dst, src=src, tmp=SOME(I.FDirect(newFreg()))},an)            (case opnd of
445      | reduceStm(T.JMP(T.LABEL lexp, labs),an) =              I.Displace _ => true
446          mark(I.JMP(I.ImmedLabel lexp, labs),an)            | I.Indexed _  => true
447      | reduceStm(T.JMP(exp, labs),an) = mark(I.JMP (operand exp, labs),an)            | I.MemReg _   => true
448      | reduceStm(T.CALL(t,def,use,mem),an) =            | I.LabelEA _  => true
449        let val addCCreg = C.addCell C.CC            | I.FDirect f  => true
450            fun addList([], acc) = acc            | _            => false
451              | addList(T.GPR(T.REG(_,r))::regs, acc) =            )
452                   addList(regs, C.addReg(r, acc))  
453              | addList(T.FPR(T.FREG(_,r))::regs, acc) =           (*
454                   addList(regs, C.addFreg(r, acc))            * Compute an integer expression and put the result in
455              | addList(T.CCR(T.CC cc)::regs, acc) =            * the destination register rd.
456                   addList(regs, addCCreg(cc, acc))            *)
457              | addList(_::regs, acc) = addList(regs, acc)        and doExpr(exp, rd : I.C.cell, an) =
458        in  mark(I.CALL(operand t,            let val rdOpnd = IntReg rd
459                        addList(def,C.empty),addList(use,C.empty),mem),an)  
460        end                fun equalRd(I.Direct r) = C.sameColor(r, rd)
461      | reduceStm(T.RET,an) = mark(I.RET NONE,an)                  | equalRd(I.MemReg r) = C.sameColor(r, rd)
462      | reduceStm(T.STORE(8, t1, t2, mem),an) =                  | equalRd _ = false
463        let val opnd = immedOrReg(operand t2)  
464            val src =                   (* Emit a binary operator.  If the destination is
465              (case opnd                    * a memReg, do something smarter.
466               of I.Direct r =>                    *)
467                    if r = C.eax then opnd else (move(opnd,eax,[]); eax)                fun genBinary(binOp, opnd1, opnd2) =
468                | _ => opnd                    if isMemReg rd andalso
469               (*esac*))                       (isMemOpnd opnd1 orelse isMemOpnd opnd2) orelse
470        in  mark(I.MOVE{mvOp=I.MOVB, src=src, dst=ea(t1,mem)},an)                       equalRd(opnd2)
471        end                    then
472      | reduceStm(T.STORE(32, t1, t2, mem),an) =                    let val tmpR = newReg()
473          move(immedOrReg(operand t2), ea(t1,mem), an)                        val tmp  = I.Direct tmpR
474      | reduceStm(T.FSTORE(64, t1, t2, mem),an) =                    in  move(opnd1, tmp);
475         (case t2                        mark(I.BINARY{binOp=binOp, src=opnd2, dst=tmp}, an);
476           of T.FREG(_,fs) => emit(I.FLD(I.FDirect fs))                        move(tmp, rdOpnd)
477            | e => reduceFexp(e,[])                    end
478          (*esac*);                    else
479          mark(I.FSTP(ea(t1,mem)),an))                       (move(opnd1, rdOpnd);
480      | reduceStm(T.BCC(_, T.CMP(ty, cc as (T.EQ | T.NE), t1, T.LI 0),                        mark(I.BINARY{binOp=binOp, src=opnd2, dst=rdOpnd}, an)
481                        lab), an) =                       )
482        let val opnd1 = operand t1  
483            fun jcc() = mark(I.JCC{cond=cond cc, opnd=immedLabel lab},an)                   (* Generate a binary operator; it may commute *)
484        in  case t1                fun binaryComm(binOp, e1, e2) =
485            of T.ANDB _ => jcc()                let val (opnd1, opnd2) =
486             | T.ORB _ =>  jcc()                        case (operand e1, operand e2) of
487             | T.XORB _ => jcc()                          (x as I.Immed _, y)      => (y, x)
488             | T.SRA _ =>  jcc()                        | (x as I.ImmedLabel _, y) => (y, x)
489             | T.SRL _ =>  jcc()                        | (x, y as I.Direct _)     => (y, x)
490             | T.SLL _ =>  jcc()                        | (x, y)                   => (x, y)
491             | _ => (emit(I.CMP{lsrc=opnd1, rsrc=I.Immed 0}); jcc())                in  genBinary(binOp, opnd1, opnd2)
492        end                end
493      | reduceStm(T.BCC(_, T.CMP(ty, cc, t1, t2), lab), an) =  
494        let fun cmpAndBranch(cc, opnd1, opnd2) =                   (* Generate a binary operator; non-commutative *)
495              (emit(I.CMP{lsrc=opnd1, rsrc=opnd2});                fun binary(binOp, e1, e2) =
496               mark(I.JCC{cond=cond cc, opnd=immedLabel lab},an))                    genBinary(binOp, operand e1, operand e2)
497    
498            val (opnd1, opnd2) = (operand t1, operand t2)                   (* Generate a unary operator *)
499        in  if isImmediate opnd1 andalso isImmediate opnd2 then                fun unary(unOp, e) =
500              cmpAndBranch(cc, moveToReg opnd1, opnd2)                let val opnd = operand e
501            else if isImmediate opnd1 then                in  if isMemReg rd andalso isMemOpnd opnd then
502              cmpAndBranch(T.Util.swapCond cc, opnd2, opnd1)                       let val tmp = I.Direct(newReg())
503            else if isImmediate opnd2 then                       in  move(opnd, tmp); move(tmp, rdOpnd)
504              cmpAndBranch(cc, opnd1, opnd2)                       end
505            else case (opnd1, opnd2)                    else move(opnd, rdOpnd);
506             of (_, I.Direct _) => cmpAndBranch(cc, opnd1, opnd2)                    mark(I.UNARY{unOp=unOp, opnd=rdOpnd}, an)
507              | (I.Direct _, _) => cmpAndBranch(cc, opnd1, opnd2)                end
508              | _ => cmpAndBranch(cc, moveToReg opnd1, opnd2)  
509             (*esac*)                   (* 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                      (* Division or remainder: divisor must be in %edx:%eax pair *)
532                  fun divrem(signed, overflow, e1, e2, resultReg) =
533                  let val (opnd1, opnd2) = (operand e1, operand e2)
534                      val _ = move(opnd1, eax)
535                      val oper = if signed then (emit(I.CDQ); I.IDIVL)
536                                 else (zero edx; I.DIVL)
537                  in  mark(I.MULTDIV{multDivOp=oper, src=regOrMem opnd2},an);
538                      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
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 *)
586                  fun uMultiply(e1, e2) =
587                      (* note e2 can never be (I.Direct edx) *)
588                      (move(operand e1, eax);
589                       mark(I.MULTDIV{multDivOp=I.MULL,
590                                      src=regOrMem(operand e2)},an);
591                       move(eax, rdOpnd)
592                      )
593    
594                      (* signed integer multiplication:
595                       * The only forms that are allowed that also sets the
596                       * OF and CF flags are:
597                       *
598                       *      imul r32, r32/m32, imm8
599                       *      imul r32, imm8
600                       *      imul r32, imm32
601                       *)
602                  fun multiply(e1, e2) =
603                  let fun doit(i1 as I.Immed _, i2 as I.Immed _, dstR, dst) =
604                          (move(i1, dst);
605                           mark(I.MUL3{dst=dstR, src1=i2, src2=NONE},an))
606                        | doit(rm, i2 as I.Immed _, dstR, dst) =
607                            doit(i2, rm, dstR, dst)
608                        | doit(imm as I.Immed(i), rm, dstR, dst) =
609                           mark(I.MUL3{dst=dstR, src1=rm, src2=SOME i},an)
610                        | doit(r1 as I.Direct _, r2 as I.Direct _, dstR, dst) =
611                          (move(r1, dst);
612                           mark(I.MUL3{dst=dstR, src1=r2, src2=NONE},an))
613                        | doit(r1 as I.Direct _, rm, dstR, dst) =
614                          (move(r1, dst);
615                           mark(I.MUL3{dst=dstR, src1=rm, src2=NONE},an))
616                        | doit(rm, r as I.Direct _, dstR, dst) =
617                           doit(r, rm, dstR, dst)
618                        | doit(rm1, rm2, dstR, dst) =
619                           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
640    
641                     (* Makes sure the destination must be a register *)
642                  fun dstMustBeReg f =
643                      if isMemReg rd then
644                      let val tmpR = newReg()
645                          val tmp  = I.Direct(tmpR)
646                      in  f(tmpR, tmp); move(tmp, rdOpnd) end
647                      else f(rd, rdOpnd)
648    
649                     (* Emit a load instruction; makes sure that the destination
650                      * is a register
651                      *)
652                  fun genLoad(mvOp, ea, mem) =
653                      dstMustBeReg(fn (_, dst) =>
654                         mark(I.MOVE{mvOp=mvOp, src=address(ea, mem), dst=dst},an))
655    
656                     (* Generate a zero extended loads *)
657                  fun load8(ea, mem) = genLoad(I.MOVZBL, ea, mem)
658                  fun load16(ea, mem) = genLoad(I.MOVZWL, ea, mem)
659                  fun load8s(ea, mem) = genLoad(I.MOVSBL, ea, mem)
660                  fun load16s(ea, mem) = genLoad(I.MOVSWL, ea, mem)
661                  fun load32(ea, mem) = genLoad(I.MOVL, ea, mem)
662    
663                     (* Generate a sign extended loads *)
664    
665                     (* Generate setcc instruction:
666                      *  semantics:  MV(rd, COND(_, T.CMP(ty, cc, t1, t2), yes, no))
667                      * Bug, if eax is either t1 or t2 then problem will occur!!!
668                      * Note that we have to use eax as the destination of the
669                      * setcc because it only works on the registers
670                      * %al, %bl, %cl, %dl and %[abcd]h.  The last four registers
671                      * are inaccessible in 32 bit mode.
672                      *)
673                  fun setcc(ty, cc, t1, t2, yes, no) =
674                  let val (cc, yes, no) =
675                             if yes > no then (cc, yes, no)
676                             else (T.Basis.negateCond cc, no, yes)
677                  in  (* Clear the destination first.
678                       * This this because stupid SETcc
679                       * only writes to the low order
680                       * byte.  That's Intel architecture, folks.
681                       *)
682                      case (yes, no, cc) of
683                        (1, 0, T.LT) =>
684                         let val tmp = I.Direct(expr(T.SUB(32,t1,t2)))
685                         in  move(tmp, rdOpnd);
686                             emit(I.BINARY{binOp=I.SHRL,src=I.Immed 31,dst=rdOpnd})
687                         end
688                      | (1, 0, T.GT) =>
689                         let val tmp = I.Direct(expr(T.SUB(32,t1,t2)))
690                         in  emit(I.UNARY{unOp=I.NOTL,opnd=tmp});
691                             move(tmp, rdOpnd);
692                             emit(I.BINARY{binOp=I.SHRL,src=I.Immed 31,dst=rdOpnd})
693                         end
694                      | (1, 0, _) => (* normal case *)
695                        let val cc = cmp(true, ty, cc, t1, t2, [])
696                        in  mark(I.SET{cond=cond cc, opnd=eax}, an);
697                            emit(I.BINARY{binOp=I.ANDL,src=I.Immed 255, dst=eax});
698                            move(eax, rdOpnd)
699                        end
700                      | (C1, C2, _)  =>
701                        (* general case;
702                         * from the Intel optimization guide p3-5
703                         *)
704                        let val _  = zero eax;
705                            val cc = cmp(true, ty, cc, t1, t2, [])
706                        in  case C1-C2 of
707                              D as (1 | 2 | 3 | 4 | 5 | 8 | 9) =>
708                              let val (base,scale) =
709                                      case D of
710                                        1 => (NONE, 0)
711                                      | 2 => (NONE, 1)
712                                      | 3 => (SOME C.eax, 1)
713                                      | 4 => (NONE, 2)
714                                      | 5 => (SOME C.eax, 2)
715                                      | 8 => (NONE, 3)
716                                      | 9 => (SOME C.eax, 3)
717                                  val addr = I.Indexed{base=base,
718                                                       index=C.eax,
719                                                       scale=scale,
720                                                       disp=I.Immed C2,
721                                                       mem=readonly}
722                                  val tmpR = newReg()
723                                  val tmp  = I.Direct tmpR
724                              in  emit(I.SET{cond=cond cc, opnd=eax});
725                                  mark(I.LEA{r32=tmpR, addr=addr}, an);
726                                  move(tmp, rdOpnd)
727                              end
728                            | D =>
729                               (emit(I.SET{cond=cond(T.Basis.negateCond cc),
730                                           opnd=eax});
731                                emit(I.UNARY{unOp=I.DECL, opnd=eax});
732                                emit(I.BINARY{binOp=I.ANDL,
733                                              src=I.Immed D, dst=eax});
734                                if C2 = 0 then
735                                   move(eax, rdOpnd)
736                                else
737                                   let val tmpR = newReg()
738                                       val tmp  = I.Direct tmpR
739                                   in  mark(I.LEA{addr=
740                                             I.Displace{
741                                                 base=C.eax,
742                                                 disp=I.Immed C2,
743                                                 mem=readonly},
744                                                 r32=tmpR}, an);
745                                        move(tmp, rdOpnd)
746                                    end
747                               )
748                        end
749                  end (* setcc *)
750    
751                      (* Generate cmovcc instruction.
752                       * on Pentium Pro and Pentium II only
753                       *)
754                  fun cmovcc(ty, cc, t1, t2, yes, no) =
755                  let fun genCmov(dstR, _) =
756                      let val _ = doExpr(no, dstR, []) (* false branch *)
757                          val cc = cmp(true, ty, cc, t1, t2, [])  (* compare *)
758                      in  mark(I.CMOV{cond=cond cc, src=operand yes, dst=dstR}, an)
759                      end
760                  in  dstMustBeReg genCmov
761                  end
762    
763                  fun unknownExp exp = doExpr(Gen.compileRexp exp, rd, an)
764    
765                      (* Add n to rd *)
766                  fun addN n =
767                  let val n = operand n
768                      val src = if isMemReg rd then immedOrReg n else n
769                  in  mark(I.BINARY{binOp=I.ADDL, src=src, dst=rdOpnd}, an) end
770    
771                      (* Generate addition *)
772                  fun addition(e1, e2) =
773                      case e1 of
774                        T.REG(_,rs) => if 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      | reduceStm(T.BCC(cc, T.CC(0), lab), an) =  
938          mark(I.JCC{cond=cond cc, opnd=immedLabel lab},an)           (* generate a condition code expression
939      | reduceStm(T.BCC _,_) = error "reduceStm: BCC"            * The zero is for setting the condition code!
940      | reduceStm(T.FBCC(_, T.FCMP(fty, fcc, t1, t2), lab),an) =            * I have no idea why this is used.
941        let fun compare() =            *)
942          and doCCexpr(T.CMP(ty, cc, t1, t2), rd, an) =
943              if C.sameColor(rd, C.eflags) then
944                 (cmp(false, ty, cc, t1, t2, an); ())
945              else
946                 error "doCCexpr: cmp"
947            | doCCexpr(T.CCMARK(e,A.MARKREG f),rd,an) = (f rd; doCCexpr(e,rd,an))
948            | doCCexpr(T.CCMARK(e,a), rd, an) = doCCexpr(e,rd,a::an)
949            | doCCexpr(T.CCEXT e, cd, an) =
950               ExtensionComp.compileCCext (reducer()) {e=e, ccd=cd, an=an}
951            | doCCexpr _ = error "doCCexpr"
952    
953         and ccExpr e = error "ccExpr"
954    
955              (* 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            let fun ignoreOrder (T.FREG _) = true
1056                  | ignoreOrder (T.FLOAD _) = true                  | ignoreOrder (T.FLOAD _) = true
1057                    | ignoreOrder (T.FMARK(e,_)) = ignoreOrder e
1058                  | ignoreOrder _ = false                  | ignoreOrder _ = false
1059                fun t2t1 () = (reduceFexp(t2,[]); reduceFexp(t1,[]))  
1060            in  if ignoreOrder t1 orelse ignoreOrder t2 then t2t1()                fun compare'() = (* Sethi-Ullman style *)
1061                else (reduceFexp(t1,[]); reduceFexp(t2,[]); emit(I.FXCH))                    (if ignoreOrder t1 orelse ignoreOrder t2 then
1062                ;                          (reduceFexp(fty, t2, []); reduceFexp(fty, t1, []))
1063                emit(I.FUCOMPP)                     else (reduceFexp(fty, t1, []); reduceFexp(fty, t2, []);
1064            end                           emit(I.FXCH{opnd=C.ST(1)}));
1065            fun branch() =                     emit(I.FUCOMPP);
1066            let val eax = I.Direct C.eax                     fcc
1067                fun andil i = emit(I.BINARY{binOp=I.AND,src=I.Immed(i),dst=eax})                    )
1068                fun xoril i = emit(I.BINARY{binOp=I.XOR,src=I.Immed(i),dst=eax})  
1069                fun cmpil i = emit(I.CMP{rsrc=I.Immed(i), lsrc=eax})                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)                fun j(cc, lab) = mark(I.JCC{cond=cc, opnd=immedLabel lab},an)
1098                fun sahf() = emit(I.SAHF)                fun sahf() = emit(I.SAHF)
1099            in  case fcc                fun branch(fcc) =
1100                      case fcc
1101                of T.==   => (andil 0x4400; xoril 0x4000; j(I.EQ, lab))                of T.==   => (andil 0x4400; xoril 0x4000; j(I.EQ, lab))
1102                 | T.?<>  => (andil 0x4400; xoril 0x4000; j(I.NE, lab))                 | T.?<>  => (andil 0x4400; xoril 0x4000; j(I.NE, lab))
1103                 | T.?    => (sahf(); j(I.P,lab))                 | T.?    => (sahf(); j(I.P,lab))
1104                 | T.<=>  => (sahf(); j(I.NP,lab))                 | T.<=>  => (sahf(); j(I.NP,lab))
1105                 | T.>    => (andil 0x4500;  j(I.EQ,lab))                     | T.>    => (testil 0x4500;  j(I.EQ,lab))
1106                 | T.?<=  => (andil 0x4500;  j(I.NE,lab))                     | T.?<=  => (testil 0x4500;  j(I.NE,lab))
1107                 | T.>=   => (andil 0x500; j(I.EQ,lab))                     | T.>=   => (testil 0x500; j(I.EQ,lab))
1108                 | T.?<   => (andil 0x500; j(I.NE,lab))                     | T.?<   => (testil 0x500; j(I.NE,lab))
1109                 | T.<    => (andil 0x4500; cmpil 0x100; j(I.EQ,lab))                 | T.<    => (andil 0x4500; cmpil 0x100; j(I.EQ,lab))
1110                 | T.?>=  => (andil 0x4500; cmpil 0x100; j(I.NE,lab))                 | T.?>=  => (andil 0x4500; cmpil 0x100; j(I.NE,lab))
1111                 | T.<=   => (andil 0x4100; cmpil 0x100; j(I.EQ,lab);                 | T.<=   => (andil 0x4100; cmpil 0x100; j(I.EQ,lab);
1112                              cmpil 0x4000; j(I.EQ,lab))                              cmpil 0x4000; j(I.EQ,lab))
1113                 | T.?>   => (sahf(); j(I.P,lab); andil 0x4100; j(I.EQ,lab))                     | T.?>   => (sahf(); j(I.P,lab); testil 0x4100; j(I.EQ,lab))
1114                 | T.<>   => (andil 0x4400; j(I.EQ,lab))                     | T.<>   => (testil 0x4400; j(I.EQ,lab))
1115                 | T.?=   => (andil 0x4400; j(I.NE,lab))                     | T.?=   => (testil 0x4400; j(I.NE,lab))
1116                       | _      => error "fbranch"
1117               (*esac*)               (*esac*)
1118                  val fcc = compare()
1119              in  emit I.FNSTSW;
1120                  branch(fcc)
1121            end            end
       in  compare(); emit I.FNSTSW; branch()  
       end  
     | reduceStm(T.FBCC _,_) = error "reduceStm: FBCC"  
     | reduceStm(T.ANNOTATION(s,a),an) = reduceStm(s,a::an)  
1122    
1123    and reduceCC(T.CMP(ty, _, t1, t2), 0, an) =        (*========================================================
1124        let val (opnd1, opnd2) = (operand t1, operand t2)         * Floating point code generation starts here.
1125        in mark(I.CMP(         * Some generic fp routines first.
1126              case (opnd1, opnd2)         *========================================================*)
             of (I.Immed _, _) => {lsrc=moveToReg opnd1, rsrc=opnd2}  
              | (I.ImmedLabel _, _) => {lsrc=moveToReg opnd1, rsrc=opnd2}  
              | (I.Const _, _) => {lsrc=moveToReg opnd1, rsrc=opnd2}  
              | (I.Direct _, _) => {lsrc=opnd1, rsrc=opnd2}  
              | (_, I.Direct _) => {lsrc=opnd1, rsrc=opnd2}  
              | _ => {lsrc=moveToReg opnd1, rsrc=opnd2}),an)  
       end  
     | reduceCC(T.CCMARK(e,a),rd,an) =  
       (case #peek MLRiscAnnotations.MARK_REG a of  
         SOME f => (f rd; reduceCC(e,rd,an))  
       | NONE => reduceCC(e,rd,a::an)  
       )  
     | reduceCC _ = error "reduceCC"  
   
   
   and reduceReg(T.REG(_,rd)) = rd  
     | reduceReg(exp) = reduceRegRd(exp, newReg(), [])  
   
  (* reduce to the register rd where possible.*)  
   and reduceRegRd(exp, rd, an) = let  
     val opndRd = I.Direct(rd)  
   
     fun binary(comm, oper, e1, e2, an) = let  
       fun emit2addr (opnd1, opnd2) =  
         (move(opnd1, opndRd, []);  
          mark(I.BINARY{binOp=oper, dst=opndRd, src=opnd2},an);  
          rd)  
       fun commute(opnd1 as I.Immed _, opnd2) = (opnd2, opnd1)  
         | commute(opnd1 as I.ImmedLabel _, opnd2) = (opnd2, opnd1)  
         | commute(opnd1 as I.Const _, opnd2) = (opnd2, opnd1)  
         | commute(opnd1, opnd2 as I.Direct _) = (opnd2, opnd1)  
         | commute arg = arg  
   
       val opnds = (operand e1, operand e2)  
     in emit2addr(if comm then commute opnds else opnds)  
     end (*binary*)  
   
     fun unary(oper, exp, an) =  
       (move(operand exp, opndRd, []);  
        mark(I.UNARY{unOp=oper, opnd=opndRd},an);  
        rd)  
1127    
1128     (* The shift count can be either an immediate or the ECX register *)         (* Can this tree be folded into the src operand of a floating point
1129      fun shift(oper, e1, e2, an) = let          * operations?
1130        val (opnd1, opnd2) = (operand e1, operand e2)          *)
1131      in        and foldableFexp(T.FREG _) = true
1132        move(opnd1, opndRd, []);          | foldableFexp(T.FLOAD _) = true
1133        case opnd2          | foldableFexp(T.CVTI2F(_, (16 | 32), _)) = true
1134         of I.Immed _ => mark(I.BINARY{binOp=oper, src=opnd2, dst=opndRd},an)          | foldableFexp(T.CVTF2F(_, _, t)) = foldableFexp t
1135          | _ => (move(opnd2, ecx, []);          | foldableFexp(T.FMARK(t, _)) = foldableFexp t
1136                  mark(I.BINARY{binOp=oper, src=ecx, dst=opndRd},an))          | foldableFexp _ = false
1137        (*esac*);  
1138        rd          (* Move integer e of size ty into a memory location.
1139      end (* shift *)           * Returns a quadruple:
1140             *  (INTEGER,return ty,effect address of memory location,cleanup code)
1141      (* Divisor must be in EDX:EAX *)           *)
1142      fun divide(oper, signed, e1, e2, an) =        and convertIntToFloat(ty, e) =
1143      let val (opnd1, opnd2) = (operand e1, operand e2)            let val opnd = operand e
1144      in  move(opnd1, eax, []);            in  if isMemOpnd opnd andalso (ty = 16 orelse ty = 32)
1145          if signed then emit(I.CDQ) else move(I.Immed(0), edx, []);                then (INTEGER, ty, opnd, [])
1146          mark(I.MULTDIV{multDivOp=oper, src=regOrMem opnd2},an);                else
1147          move(eax, opndRd, []);                  let val {instrs, tempMem, cleanup} = cvti2f{ty=ty, src=opnd}
1148          rd                  in  emits instrs;
1149                        (INTEGER, 32, tempMem, cleanup)
1150                    end
1151      end      end
1152    
1153      (* unsigned integer multiplication *)        (*========================================================
1154      fun uMultiply(e1, e2, an) =         * Sethi-Ullman based floating point code generation as
1155        (* note e2 can never be (I.Direct edx) *)         * implemented by Lal
1156        (move(operand e1, eax, []);         *========================================================*)
1157         mark(I.MULTDIV{multDivOp=I.UMUL, src=regOrMem(operand e2)},an);  
1158         move(eax, opndRd, []);        and fld(32, opnd) = I.FLDS opnd
1159         rd)          | fld(64, opnd) = I.FLDL opnd
1160            | fld(80, opnd) = I.FLDT opnd
1161      (* signed integer multiplication *)          | 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      (* The only forms that are allowed that also sets the            (* generate code for floating point loads *)
1185       * OF and CF flags are:        and fload'(fty, ea, mem, fd, an) =
1186       *              let val ea = address(ea, mem)
1187       *      imul r32, r32/m32, imm8              in  mark(fld(fty, ea), an);
1188       *            imul r32, imm8                  if C.sameColor(fd,ST0) then ()
1189       *      imul r32, imm32                  else emit(fstp(fty, I.FDirect fd))
      *)  
     fun multiply(e1, e2, an) = let  
       fun doit(i1 as I.Immed _, i2 as I.Immed _) =  
             (move(i1, opndRd, []);  
             mark(I.MUL3{dst=rd, src1=i2, src2=NONE},an))  
         | doit(rm, i2 as I.Immed _) = doit(i2, rm)  
         | doit(imm as I.Immed(i), rm) =  
              mark(I.MUL3{dst=rd, src1=rm, src2=SOME i},an)  
         | doit(r1 as I.Direct _, r2 as I.Direct _) =  
             (move(r1, opndRd, []);  
              mark(I.MUL3{dst=rd, src1=r2, src2=NONE},an))  
         | doit(r1 as I.Direct _, rm) =  
             (move(r1, opndRd, []);  
              mark(I.MUL3{dst=rd, src1=rm, src2=NONE},an))  
         | doit(rm, r as I.Direct _) = doit(r, rm)  
         | doit(rm1, rm2) =  
            (move(rm1, opndRd, []);  
             mark(I.MUL3{dst=rd, src1=rm2, src2=NONE},an))  
     in doit(operand e1, operand e2)  
1190      end      end
1191    
1192      fun trap() =        and fexpr' e = (reduceFexp(64, e, []); C.ST(0))
1193        (case !trapLabel  
1194         of NONE => (trapLabel := SOME(Label.newLabel "trap"); trap())            (* generate floating point expression and put the result in fd *)
1195          | SOME lab => emit(I.JCC{cond=I.O, opnd=I.ImmedLabel(LE.LABEL lab)})        and doFexpr'(fty, T.FREG(_, fs), fd, an) =
1196        (*esac*))              (if C.sameColor(fs,fd) then ()
1197    in               else mark(I.FCOPY{dst=[fd], src=[fs], tmp=NONE}, an)
1198      case exp              )
1199       of T.REG(_,rs) => (move(I.Direct rs, opndRd, an); rd)          | doFexpr'(_, T.FLOAD(fty, ea, mem), fd, an) =
1200        | T.LI n         => (move(I.Immed(toInt32 n), opndRd, an); rd)              fload'(fty, ea, mem, fd, an)
1201        | T.LI32 w => (move(I.Immed(wToInt32 w), opndRd, an); rd)          | doFexpr'(fty, T.FEXT fexp, fd, an) =
1202        | T.CONST c => (move(I.Const c, opndRd, an); rd)              (ExtensionComp.compileFext (reducer()) {e=fexp, fd=fd, an=an};
1203        | T.LABEL lab => (move(I.ImmedLabel lab, opndRd, an); rd)               if C.sameColor(fd,ST0) then () else emit(fstp(fty, I.FDirect fd))
1204        | T.ADD(32, e, T.LI 1) => unary(I.INC, e, an)              )
1205        | T.ADD(32, e, T.LI32 0w1) => unary(I.INC, e, an)          | doFexpr'(fty, e, fd, an) =
1206        | T.ADD(32, e, T.LI ~1) => unary(I.DEC, e, an)              (reduceFexp(fty, e, []);
1207        | T.ADD(32, e1, e2) =>               if C.sameColor(fd,ST0) then ()
1208            ((mark(I.LEA{r32=rd, addr=ea(exp,I.Region.readonly)}, an); rd)               else mark(fstp(fty, I.FDirect fd), an)
1209              handle EA => binary(true, I.ADD, e1, e2, an))              )
       | T.SUB(32, e, T.LI 1) => unary(I.DEC, e, an)  
       | T.SUB(32, e, T.LI32 0w1)        => unary(I.DEC, e, an)  
       | T.SUB(32, e, T.LI ~1) => unary(I.INC, e, an)  
       | T.SUB(32, e1, e2) => binary(false, I.SUB, e1, e2, an)  
       | T.MULU(32, e1, e2) => uMultiply(e1, e2, an)  
       | T.DIVU(32, e1, e2) => (divide(I.UDIV, false, e1, e2, an))  
       | T.ADDT(32, e1, e2) => (binary(true,I.ADD,e1,e2, an); trap(); rd)  
       | T.MULT(32, e1, e2) => (multiply(e1, e2, an); trap(); rd)  
       | T.SUBT(32, e1, e2) =>  
          (binary(false,I.SUB,e1,e2, an); trap(); rd)  
       | T.DIVT(32, e1, e2) =>  
           (divide(I.IDIV, true, e1, e2, an); trap(); rd)  
       | T.LOAD(32, exp, mem) => (move(ea(exp,mem), opndRd, an); rd)  
       | T.LOAD(8, exp, mem) =>  
           (mark(I.MOVE{mvOp=I.MOVZX, src=ea(exp,mem), dst=opndRd}, an); rd)  
       | T.ANDB(32, e1, e2) => binary(true, I.AND, e1, e2, an)  
       | T.ORB(32, e1, e2) => binary(true, I.OR, e1, e2, an)  
       | T.XORB(32, e1, e2) => binary(true, I.XOR, e1, e2, an)  
       | T.SRA(32, e1, e2) => shift(I.SAR, e1, e2, an)  
       | T.SRL(32, e1, e2) => shift(I.SHR, e1, e2, an)  
       | T.SLL(32, e1, e2) => shift(I.SHL, e1, e2, an)  
       | T.SEQ(stm, rexp)  => (reduceStm(stm,[]); reduceRegRd(rexp, rd, an))  
       | T.MARK(e,a) =>  
         (case #peek MLRiscAnnotations.MARK_REG a of  
           SOME f => (f rd; reduceRegRd(e,rd,an))  
         | NONE => reduceRegRd(e,rd,a::an)  
         )  
   
   end (* reduceRegRd *)  
   
   and reduceFexp(fexp, an) = let  
     val ST = I.FDirect(C.FPReg 0)  
     val ST1 = I.FDirect(C.FPReg 1)  
   
     datatype su_numbers =  
        LEAF of int  
      | BINARY of int * su_numbers * su_numbers  
      | UNARY of int * su_numbers  
   
     fun label(LEAF n) = n  
       | label(BINARY(n, _, _)) = n  
       | label(UNARY(n, _)) = n  
   
     datatype direction = LEFT | RIGHT  
   
    (* Generate tree of sethi-ullman numbers *)  
     fun suBinary(t1, t2) = let  
       val su1 = suNumbering(t1, LEFT)  
       val su2 = suNumbering(t2, RIGHT)  
       val n1 = label su1  
       val n2 = label su2  
     in BINARY(if n1=n2 then n1+1 else Int.max(n1, n2), su1, su2)  
     end  
   
     and suUnary(t) = let  
       val su = suNumbering(t, LEFT)  
     in UNARY(label su, su)  
     end  
   
     and suNumbering(T.FREG _, LEFT) = LEAF 1  
       | suNumbering(T.FREG _, RIGHT) = LEAF 0  
       | suNumbering(T.FLOAD _, LEFT) = LEAF 1  
       | suNumbering(T.FLOAD _, RIGHT) = LEAF 0  
       | suNumbering(T.FADD(_, t1, t2), _) = suBinary(t1, t2)  
       | suNumbering(T.FMUL(_, t1, t2), _) = suBinary(t1, t2)  
       | suNumbering(T.FSUB(_, t1, t2), _) = suBinary(t1, t2)  
       | suNumbering(T.FDIV(_, t1, t2), _) = suBinary(t1, t2)  
       | suNumbering(T.FABS(_,t), _) = suUnary(t)  
       | suNumbering(T.FNEG(_,t), _) = suUnary(t)  
       | suNumbering(T.CVTI2F _, _) = UNARY(1, LEAF 0)  
       | suNumbering(T.FMARK(e,a),x) = suNumbering(e,x)  
   
     fun leafEA(T.FREG(_,f)) = I.FDirect f  
       | leafEA(T.FLOAD(_, t, mem)) = ea(t,mem)  
       | leafEA _ = error "leafEA"  
1210    
1211      fun cvti2d(t,an) = let            (*
1212        val opnd = operand t             * Generate floating point expression using Sethi-Ullman's scheme:
1213        fun doMemOpnd () =             * This function evaluates a floating point expression,
1214          (emit(I.MOVE{mvOp=I.MOVL, src=opnd, dst=tempMem});             * and put result in %ST(0).
1215           mark(I.FILD tempMem,an))             *)
1216      in        and reduceFexp(fty, fexp, an)  =
1217        case opnd            let val ST = I.ST(C.ST 0)
1218        of I.Direct _ => doMemOpnd()                val ST1 = I.ST(C.ST 1)
1219         | I.Immed _ => doMemOpnd()                val cleanupCode = ref [] : I.instruction list ref
1220         | _ => mark(I.FILD opnd, an)  
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      end
1278    
1279      (* traverse expression and su-number tree *)                (* Try to fold in the operand if possible.
1280      fun gencode(_, LEAF 0, an) = ()                 * This only applies to commutative operations.
1281        | gencode(T.FMARK(e,a), x, an) = gencode(e, x, a::an)                 *)
1282        | gencode(f, LEAF 1, an) = mark(I.FLD(leafEA f), an)                and suComBinary(fty, binop, ibinop, t1, t2) =
1283        | gencode(t, BINARY(_, su1, LEAF 0), an) = let                    let val (t1, t2) = if foldableFexp t2
1284            fun doit(oper, t1, t2) =                                       then (t1, t2) else (t2, t1)
1285              (gencode(t1, su1, []);                    in  suBinary(fty, binop, ibinop, t1, t2) end
1286               mark(I.FBINARY{binOp=oper, src=leafEA t2, dst=ST},an))  
1287          in                and sameTree(LEAF(_, T.FREG(t1,f1), []),
1288            case t                             LEAF(_, T.FREG(t2,f2), [])) =
1289            of T.FADD(_, t1, t2) => doit(I.FADD, t1, t2)                          t1 = t2 andalso C.sameColor(f1,f2)
1290             | T.FMUL(_, t1, t2) => doit(I.FMUL, t1, t2)                  | sameTree _ = false
1291             | T.FSUB(_, t1, t2) => doit(I.FSUB, t1, t2)  
1292             | T.FDIV(_, t1, t2) => doit(I.FDIV, t1, t2)                (* Traverse tree and generate code *)
1293          end                fun gencode(LEAF(_, t, an)) = mark(fxld(leafEA t), an)
1294        | gencode(fexp, BINARY(_, su1, su2), an) = let                  | gencode(BINARY(_, _, binop, x, t2 as LEAF(0, y, a1), a2)) =
1295            fun doit(t1, t2, oper, operP, operRP) = let                    let val _          = gencode x
1296             (* oper[P] =>  ST(1) := ST oper ST(1); [pop]                        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,
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.498  
changed lines
  Added in v.744

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