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

SCM Repository

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

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

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

revision 499, Tue Dec 7 15:44:50 1999 UTC revision 545, Thu Feb 24 13:56:44 2000 UTC
# Line 2  Line 2 
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     * -- Allen
26   *)   *)
27    local
28       val rewriteMemReg = true (* should we rewrite memRegs *)
29    in
30    
31  functor X86  functor X86
32    (structure X86Instr : X86INSTR    (structure X86Instr : X86INSTR
33     structure X86MLTree : MLTREE     structure X86MLTree : MLTREE
34      (* structure PseudoInstrs : X86_PSEUDO_INSTR *)
35       sharing X86MLTree.Region = X86Instr.Region       sharing X86MLTree.Region = X86Instr.Region
36       sharing X86MLTree.Constant = X86Instr.Constant       sharing X86MLTree.LabelExp = X86Instr.LabelExp
37     val tempMem : X86Instr.operand) : MLTREECOMP =       (* sharing PseudoInstrs.I = X86Instr
38         sharing PseudoInstrs.T = X86MLTree *)
39        datatype arch = Pentium | PentiumPro | PentiumII | PentiumIII
40        val arch : arch ref
41        val tempMem : X86Instr.operand (* temporary for CVTI2F *)
42        (* val memRegsUsed : word ref *)    (* bit mask of memRegs used *)
43      ) : sig include MLTREECOMP
44              val rewriteMemReg : bool
45          end =
46  struct  struct
47    structure T = X86MLTree    structure T = X86MLTree
48    structure S = T.Stream    structure S = T.Stream
49    structure I = X86Instr    structure I = X86Instr
50    structure C = X86Cells    structure C = I.C
51      structure Shuffle = Shuffle(I)
52    structure W32 = Word32    structure W32 = Word32
53    structure LE = LabelExp    structure LE = I.LabelExp
54      structure A = MLRiscAnnotations
55    
56      type instrStream = (I.instruction,C.regmap,C.cellset) T.stream
57      type ('s,'r,'f,'c) mltreeStream =
58         (('s,'r,'f,'c) T.stm,C.regmap,('s,'r,'f,'c) T.mlrisc list) T.stream
59      type ('s,'r,'f,'c) reducer =
60         (I.instruction,C.regmap,C.cellset,I.operand,I.addressing_mode,'s,'r,'f,'c)
61           T.reducer
62      type ('s,'r,'f,'c) extender =
63         (I.instruction,C.regmap,C.cellset,I.operand,I.addressing_mode,'s,'r,'f,'c)
64           T.extender
65    
66      structure Gen = MLTreeGen
67         (structure T = T
68          val intTy = 32
69          val naturalWidths = [32]
70          datatype rep = SE | ZE | NEITHER
71          val rep = NEITHER
72         )
73    
74    fun error msg = MLRiscErrorMsg.error("X86",msg)    fun error msg = MLRiscErrorMsg.error("X86",msg)
75    
76    (* label where a trap is generated -- one per cluster *)    (* Should we perform automatic MemReg translation?
77    val trapLabel = ref (NONE: Label.label option)     * If this is on, we can avoid doing RewritePseudo phase entirely.
78       *)
79      val rewriteMemReg = rewriteMemReg
80      fun isMemReg r = rewriteMemReg andalso r >= 8 andalso r < 32
81    
82      (*
83       * The code generator
84       *)
85    fun selectInstructions    fun selectInstructions
86         (S.STREAM{emit,defineLabel,entryLabel,pseudoOp,annotation,         (T.EXTENDER{compileStm,compileRexp,compileFexp,compileCCexp,...})
87           (instrStream as
88            S.STREAM{emit,defineLabel,entryLabel,pseudoOp,annotation,
89                   beginCluster,endCluster,exitBlock,alias,phi,comment,...}) =                   beginCluster,endCluster,exitBlock,alias,phi,comment,...}) =
90    let    let exception EA
91    
92          (* label where a trap is generated -- one per cluster *)
93          val trapLabel = ref (NONE: (I.instruction * Label.label) option)
94    
95          (* effective address of an integer register *)
96          fun IntReg r = if isMemReg r then MemReg r else I.Direct r
97          and MemReg r =
98              ((* memRegsUsed := Word.orb(!memRegsUsed,
99                                Word.<<(0w1, Word.fromInt r-0w8)); *)
100               I.MemReg r
101              )
102    
103          (* Add an overflow trap *)
104          fun trap() =
105          let val jmp =
106                case !trapLabel of
107                  NONE => let val label = Label.newLabel "trap"
108                              val jmp   = I.JCC{cond=I.O,
109                                                opnd=I.ImmedLabel(LE.LABEL label)}
110                          in  trapLabel := SOME(jmp, label); jmp end
111                | SOME(jmp, _) => jmp
112          in  emit jmp end
113    
114    val newReg  = C.newReg    val newReg  = C.newReg
115    val newFreg = C.newFreg    val newFreg = C.newFreg
116    
117    (* annotations *)        (* mark an expression with a list of annotations *)
118    fun mark'(i,[]) = i    fun mark'(i,[]) = i
119      | mark'(i,a::an) = mark'(I.ANNOTATION{i=i,a=a},an)      | mark'(i,a::an) = mark'(I.ANNOTATION{i=i,a=a},an)
120    
121          (* annotate an expression and emit it *)
122    fun mark(i,an) = emit(mark'(i,an))    fun mark(i,an) = emit(mark'(i,an))
123    
124          (* emit parallel copies for integers
125           * Translates parallel copies that involve memregs into
126           * individual copies.
127           *)
128          fun copy([], [], an) = ()
129            | copy(dst, src, an) =
130              let fun mvInstr{dst as I.MemReg rd, src as I.MemReg rs} =
131                      if rd = rs then [] else
132                      let val tmpR = I.Direct(newReg())
133                      in  [I.MOVE{mvOp=I.MOVL, src=src, dst=tmpR},
134                           I.MOVE{mvOp=I.MOVL, src=tmpR, dst=dst}]
135                      end
136                    | mvInstr{dst=I.Direct rd, src=I.Direct rs} =
137                        if rd = rs then []
138                        else [I.COPY{dst=[rd], src=[rs], tmp=NONE}]
139                    | mvInstr{dst, src} = [I.MOVE{mvOp=I.MOVL, src=src, dst=dst}]
140              in
141                 app emit (Shuffle.shuffle{mvInstr=mvInstr, ea=IntReg}
142                   {regmap=fn r => r, tmp=SOME(I.Direct(newReg())),
143                    dst=dst, src=src})
144              end
145    
146    (* conversions *)    (* conversions *)
147    val itow = Word.fromInt    val itow = Word.fromInt
148    val wtoi = Word.toInt    val wtoi = Word.toInt
149    val toInt32 = Int32.fromLarge o Int.toLarge        fun toInt32 i = Int32.fromLarge(Int.toLarge i)
150          val w32toi32 = Word32.toLargeIntX
151          val i32tow32 = Word32.fromLargeInt
152    
153    (* One day, this is going to bite us when precision(LargeInt)>32 *)    (* One day, this is going to bite us when precision(LargeInt)>32 *)
154    val wToInt32 = Int32.fromLarge o Word32.toLargeIntX        fun wToInt32 w = Int32.fromLarge(Word32.toLargeIntX w)
155    
156    (* some useful registers *)    (* some useful registers *)
157    val eax = I.Direct(C.eax)    val eax = I.Direct(C.eax)
158    val ecx = I.Direct(C.ecx)    val ecx = I.Direct(C.ecx)
159    val edx = I.Direct(C.edx)    val edx = I.Direct(C.edx)
160    
   fun immed8 n = Int32.>=(n, ~256) andalso Int32.<(n,256)  
161    fun immedLabel lab = I.ImmedLabel(LE.LABEL lab)    fun immedLabel lab = I.ImmedLabel(LE.LABEL lab)
162    
163    fun move(src as I.Direct s, dst as I.Direct d, an) =        (* Is the expression zero? *)
164          fun isZero(T.LI 0) = true
165            | isZero(T.LI32 0w0) = true
166            | isZero(T.MARK(e,a)) = isZero e
167            | isZero _ = false
168           (* Does the expression set the zero bit?
169            * WARNING: we assume these things are not optimized out!
170            *)
171          fun setZeroBit(T.ANDB _)     = true
172            | setZeroBit(T.ORB _)      = true
173            | setZeroBit(T.XORB _)     = true
174            | setZeroBit(T.SRA _)      = true
175            | setZeroBit(T.SRL _)      = true
176            | setZeroBit(T.SLL _)      = true
177            | setZeroBit(T.MARK(e, _)) = setZeroBit e
178            | setZeroBit _             = false
179    
180          (* emit parallel copies for floating point *)
181          fun fcopy(fty, [], [], _) = ()
182            | fcopy(fty, dst as [_], src as [_], an) =
183                mark(I.FCOPY{dst=dst,src=src,tmp=NONE}, an)
184            | fcopy(fty, dst, src, an) =
185                mark(I.FCOPY{dst=dst,src=src,tmp=SOME(I.FDirect(newFreg()))}, an)
186    
187          (* Translates MLTREE condition code to x86 condition code *)
188          fun cond T.LT = I.LT | cond T.LTU = I.B
189            | cond T.LE = I.LE | cond T.LEU = I.BE
190            | cond T.EQ = I.EQ | cond T.NE  = I.NE
191            | cond T.GE = I.GE | cond T.GEU = I.AE
192            | cond T.GT = I.GT | cond T.GTU = I.A
193    
194          (* Move and annotate *)
195          fun move'(src as I.Direct s, dst as I.Direct d, an) =
196        if s=d then ()        if s=d then ()
197        else mark(I.COPY{dst=[d], src=[s], tmp=NONE}, an)        else mark(I.COPY{dst=[d], src=[s], tmp=NONE}, an)
198      | move(src, dst, an) = mark(I.MOVE{mvOp=I.MOVL, src=src, dst=dst}, an)          | move'(src, dst, an) = mark(I.MOVE{mvOp=I.MOVL, src=src, dst=dst}, an)
199    
200          (* Move only! *)
201          fun move(src, dst) = move'(src, dst, [])
202    
203          fun zero dst = emit(I.BINARY{binOp=I.XORL, src=dst, dst=dst})
204    
205          val readonly = I.Region.readonly
206    
207          (*
208           * Compute an effective address.  This is a new version
209           *)
210          fun address(ea, mem) =
211          let (* tricky way to negate without overflow! *)
212              fun neg32 w = Word32.notb w + 0w1
213    
214              (* Keep building a bigger and bigger effective address expressions
215               * The input is a list of trees
216               * b -- base
217               * i -- index
218               * s -- scale
219               * d -- immed displacement
220               *)
221              fun doEA([], b, i, s, d) = makeAddressingMode(b, i, s, d)
222                | doEA(t::trees, b, i, s, d) =
223                  (case t of
224                     T.LI n   => doEAImmed(trees, n, b, i, s, d)
225                   | T.LI32 n => doEAImmedw(trees, n, b, i, s, d)
226                   | T.CONST c => doEALabel(trees, LE.CONST c, b, i, s, d)
227                   | T.LABEL le => doEALabel(trees, le, b, i, s, d)
228                   | T.ADD(32, t1, t2 as T.REG(_,r)) =>
229                        if isMemReg r then doEA(t2::t1::trees, b, i, s, d)
230                        else doEA(t1::t2::trees, b, i, s, d)
231                   | T.ADD(32, t1, t2) => doEA(t1::t2::trees, b, i, s, d)
232                   | T.SUB(32, t1, T.LI n) =>
233                        (* can't overflow here *)
234                        doEA(t1::T.LI32(neg32(Word32.fromInt n))::trees, b, i, s, d)
235                   | T.SUB(32, t1, T.LI32 n) =>
236                        doEA(t1::T.LI32(neg32 n)::trees, b, i, s, d)
237                   | T.SLL(32, t1, T.LI 0) => displace(trees, t1, b, i, s, d)
238                   | T.SLL(32, t1, T.LI 1) => indexed(trees, t1, t, 1, b, i, s, d)
239                   | T.SLL(32, t1, T.LI 2) => indexed(trees, t1, t, 2, b, i, s, d)
240                   | T.SLL(32, t1, T.LI 3) => indexed(trees, t1, t, 3, b, i, s, d)
241                   | T.SLL(32, t1, T.LI32 0w0) => displace(trees, t1, b, i, s, d)
242                   | T.SLL(32, t1, T.LI32 0w1) => indexed(trees,t1,t,1,b,i,s,d)
243                   | T.SLL(32, t1, T.LI32 0w2) => indexed(trees,t1,t,2,b,i,s,d)
244                   | T.SLL(32, t1, T.LI32 0w3) => indexed(trees,t1,t,3,b,i,s,d)
245                   | t => displace(trees, t, b, i, s, d)
246                  )
247    
248    fun moveToReg(opnd) =            (* Add an immed constant *)
249              and doEAImmed(trees, 0, b, i, s, d) = doEA(trees, b, i, s, d)
250                | doEAImmed(trees, n, b, i, s, I.Immed m) =
251                     doEA(trees, b, i, s, (* no overflow! *)
252                           I.Immed(w32toi32(Word32.fromInt n + i32tow32 m)))
253                | doEAImmed(trees, n, b, i, s, I.ImmedLabel le) =
254                     doEA(trees, b, i, s, I.ImmedLabel(LE.PLUS(le,LE.INT n)))
255                | doEAImmed(trees, n, b, i, s, _) = error "doEAImmed"
256    
257              (* Add an immed32 constant *)
258              and doEAImmedw(trees, 0w0, b, i, s, d) = doEA(trees, b, i, s, d)
259                | doEAImmedw(trees, n, b, i, s, I.Immed m) =
260                     (* no overflow! *)
261                     doEA(trees, b, i, s, I.Immed(w32toi32(i32tow32 m + n)))
262                | doEAImmedw(trees, n, b, i, s, I.ImmedLabel le) =
263                     doEA(trees, b, i, s,
264                          I.ImmedLabel(LE.PLUS(le,LE.INT(Word32.toIntX n)))
265                          handle Overflow => error "doEAImmedw: constant too large")
266                | doEAImmedw(trees, n, b, i, s, _) = error "doEAImmedw"
267    
268              (* Add a label expression *)
269              and doEALabel(trees, le, b, i, s, I.Immed 0) =
270                     doEA(trees, b, i, s, I.ImmedLabel le)
271                | doEALabel(trees, le, b, i, s, I.Immed m) =
272                     doEA(trees, b, i, s,
273                          I.ImmedLabel(LE.PLUS(le,LE.INT(Int32.toInt m)))
274                          handle Overflow => error "doEALabel: constant too large")
275                | doEALabel(trees, le, b, i, s, I.ImmedLabel le') =
276                     doEA(trees, b, i, s, I.ImmedLabel(LE.PLUS(le,le')))
277                | doEALabel(trees, le, b, i, s, _) = error "doEALabel"
278    
279              and makeAddressingMode(NONE, NONE, _, disp) = disp
280                | makeAddressingMode(SOME base, NONE, _, disp) =
281                    I.Displace{base=base, disp=disp, mem=mem}
282                | makeAddressingMode(base, SOME index, scale, disp) =
283                    I.Indexed{base=base, index=index, scale=scale,
284                              disp=disp, mem=mem}
285    
286              (* generate code for tree and ensure that it is not in %esp *)
287              and exprNotEsp tree =
288                  let val r = expr tree
289                  in  if r = C.esp then
290                         let val tmp = newReg()
291                         in  move(I.Direct r, I.Direct tmp); tmp end
292                      else r
293                  end
294    
295              (* Add a base register *)
296              and displace(trees, t, NONE, i, s, d) =  (* no base yet *)
297                   doEA(trees, SOME(expr t), i, s, d)
298                | displace(trees, t, b as SOME base, NONE, _, d) = (* no index *)
299                  (* make t the index, but make sure that it is not %esp! *)
300                  let val i = expr t
301                  in  if i = C.esp then
302                        (* swap base and index *)
303                        if base <> C.esp then
304                           doEA(trees, SOME i, b, 0, d)
305                        else  (* base and index = %esp! *)
306                           let val index = newReg()
307                           in  move(I.Direct i, I.Direct index);
308                               doEA(trees, b, SOME index, 0, d)
309                           end
310                      else
311                        doEA(trees, b, SOME i, 0, d)
312                  end
313                | displace(trees, t, SOME base, i, s, d) = (* base and index *)
314                  let val b = expr(T.ADD(32,T.REG(32,base),t))
315                  in  doEA(trees, SOME b, i, s, d) end
316    
317              (* Add an indexed register *)
318              and indexed(trees, t, t0, scale, b, NONE, _, d) = (* no index yet *)
319                   doEA(trees, b, SOME(exprNotEsp t), scale, d)
320                | indexed(trees, _, t0, _, NONE, i, s, d) = (* no base *)
321                   doEA(trees, SOME(expr t0), i, s, d)
322                | indexed(trees, _, t0, _, SOME base, i, s, d) = (*base and index*)
323                   let val b = expr(T.ADD(32, t0, T.REG(32, base)))
324                   in  doEA(trees, SOME b, i, s, d) end
325    
326          in  case doEA([ea], NONE, NONE, 0, I.Immed 0) of
327                I.Immed _ => raise EA
328              | I.ImmedLabel le => I.LabelEA le
329              | ea => ea
330          end (* address *)
331    
332              (* reduce an expression into an operand *)
333          and operand(T.LI i) = I.Immed(toInt32 i)
334            | operand(T.LI32 w) = I.Immed(wToInt32 w)
335            | operand(T.CONST c) = I.ImmedLabel(LE.CONST c)
336            | operand(T.LABEL lab) = I.ImmedLabel lab
337            | operand(T.REG(_,r)) = IntReg r
338            | operand(T.LOAD(32,ea,mem)) = address(ea, mem)
339            | operand(t) = I.Direct(expr t)
340    
341          and moveToReg(opnd) =
342    let val dst = I.Direct(newReg())    let val dst = I.Direct(newReg())
343    in  move(opnd, dst, []); dst            in  move(opnd, dst); dst
344              end
345    
346          and reduceOpnd(I.Direct r) = r
347            | reduceOpnd opnd =
348              let val dst = newReg()
349              in  move(opnd, I.Direct dst); dst
350    end    end
351    
352    (* ensure that the operand is either an immed or register *)    (* ensure that the operand is either an immed or register *)
353    fun immedOrReg opnd =        and immedOrReg(opnd as I.Displace _) = moveToReg opnd
354      case opnd          | immedOrReg(opnd as I.Indexed _)  = moveToReg opnd
355       of I.Displace _ => moveToReg opnd          | immedOrReg(opnd as I.MemReg _)   = moveToReg opnd
356        | I.Indexed _ =>  moveToReg opnd          | immedOrReg(opnd as I.LabelEA _)  = moveToReg opnd
357        | _  => opnd          | immedOrReg opnd  = opnd
     (*esac*)  
358    
359    fun isImmediate(I.Immed _) = true        and isImmediate(I.Immed _) = true
360      | isImmediate(I.ImmedLabel _) = true      | isImmediate(I.ImmedLabel _) = true
     | isImmediate(I.Const _) = true  
     | isImmediate(I.LabelEA _) = true  
361      | isImmediate _ = false      | isImmediate _ = false
362    
363    fun regOrMem opnd = if isImmediate opnd then moveToReg opnd else opnd        and regOrMem opnd = if isImmediate opnd then moveToReg opnd else opnd
364    
365          and isMemOpnd opnd =
366              (case opnd of
367                I.Displace _ => true
368              | I.Indexed _  => true
369              | I.MemReg _   => true
370              | I.LabelEA _  => true
371              | _            => false
372              )
373    
374  fun rexp(T.REG(_,r)) = ["r" ^ Int.toString r]           (*
375    | rexp(T.LI i)  = ["LI"]            * Compute an integer expression and put the result in
376    | rexp(T.LI32 i32) = ["LI32"]            * the destination register rd.
377    | rexp(T.LABEL le) = ["LABEL"]            *)
378    | rexp(T.CONST c) = ["CONST"]        and doExpr(exp, rd : I.C.cell, an) =
379              let val rdOpnd = IntReg rd
   | rexp(T.ADD  (_, e1, e2)) = ["ADD("] @ rexp e1 @ (","::rexp e2) @ [")"]  
   | rexp(T.SUB  (_, e1, e2)) = ["SUB"]  
   | rexp(T.MULU (_, e1, e2)) = ["MULU"]  
   | rexp(T.DIVU (_, e1, e2)) =  ["DIVU"]  
   
   | rexp(T.ADDT (_, e1, e2)) =   ["ADDT"]  
   | rexp(T.MULT (_, e1, e2)) =  ["MULT"]  
   | rexp(T.SUBT (_, e1, e2)) = ["SUBT"]  
   | rexp(T.DIVT (_, e1, e2)) = ["DIVT"]  
   
   | rexp(T.LOAD (8, e, _)) = ["LOAD8("] @ rexp e @ [")"]  
   | rexp(T.LOAD (32, e, _)) = ["LOAD32"]  
   
   | rexp(T.ANDB (_, e1, e2)) =  ["AND"]  
   | rexp(T.ORB  (_, e1, e2)) = ["OR"]  
   | rexp(T.XORB (_, e1, e2)) = ["XOR"]  
   
   | rexp(T.SRA  (_, e1, e2)) = ["SRA("] @ rexp e1 @ (","::rexp e2) @ [")"]  
   | rexp(T.SRL  (_, e1, e2)) = ["SRL"]  
   | rexp(T.SLL  (_, e1, e2)) = ["SLL"]  
   
   | rexp(T.SEQ(s, e)) = ["SEQ("] @ stm s @ ("," :: rexp e) @ [")"]  
   
 and stm s =  
  (case s  
   of T.MV(_, r, e) => ["MV(", Int.toString r] @ (",":: rexp e) @ [")"]  
    | T.FMV _ => ["FMV"]  
    | T.COPY _  => ["COPY"]  
    | T.FCOPY _ => ["FCOPY"]  
    | T.JMP _ => ["JMP"]  
    | T.CALL _ => ["CALL"]  
    | T.RET  => ["RET"]  
    | T.STORE _ => ["STORE"]  
    | T.FSTORE _ => ["FSTORE"]  
    | T.BCC    _ => ["BCC"]  
    | T.FBCC   _ => ["FBCC"]  
   (*esac*))  
380    
381  fun prMLRisc s = print(concat(stm s))                fun equalRd(I.Direct r) = r = rd
382                    | equalRd(I.MemReg r) = r = rd
383                    | equalRd _ = false
384    
385                     (* Emit a binary operator.  If the destination is
386                      * a memReg, do something smarter.
387                      *)
388                  fun genBinary(binOp, opnd1, opnd2) =
389                      if isMemReg rd andalso
390                         (isMemOpnd opnd1 orelse isMemOpnd opnd2) orelse
391                         equalRd(opnd2)
392                      then
393                      let val tmpR = newReg()
394                          val tmp  = I.Direct tmpR
395                      in  move(opnd1, tmp);
396                          mark(I.BINARY{binOp=binOp, src=opnd2, dst=tmp}, an);
397                          move(tmp, rdOpnd)
398                      end
399                      else
400                         (move(opnd1, rdOpnd);
401                          mark(I.BINARY{binOp=binOp, src=opnd2, dst=rdOpnd}, an)
402                         )
403    
404                     (* Generate a binary operator; it may commute *)
405                  fun binaryComm(binOp, e1, e2) =
406                  let val (opnd1, opnd2) =
407                          case (operand e1, operand e2) of
408                            (x as I.Immed _, y)      => (y, x)
409                          | (x as I.ImmedLabel _, y) => (y, x)
410                          | (x, y as I.Direct _)     => (y, x)
411                          | (x, y)                   => (x, y)
412                  in  genBinary(binOp, opnd1, opnd2)
413                  end
414    
415                     (* Generate a binary operator; non-commutative *)
416                  fun binary(binOp, e1, e2) =
417                      genBinary(binOp, operand e1, operand e2)
418    
419                     (* Generate a unary operator *)
420                  fun unary(unOp, e) =
421                  let val opnd = operand e
422                  in  if isMemReg rd andalso isMemOpnd opnd then
423                         let val tmp = I.Direct(newReg())
424                         in  move(opnd, tmp); move(tmp, rdOpnd)
425                         end
426                      else move(opnd, rdOpnd);
427                      mark(I.UNARY{unOp=unOp, opnd=rdOpnd}, an)
428                  end
429    
430                     (* Generate shifts; the shift
431                      * amount must be a constant or in %ecx *)
432                  fun shift(opcode, e1, e2) =
433                  let val (opnd1, opnd2) = (operand e1, operand e2)
434                  in  case opnd2 of
435                        I.Immed _ => genBinary(opcode, opnd1, opnd2)
436                      | _ =>
437                        if equalRd(opnd2) then
438                        let val tmpR = newReg()
439                            val tmp  = I.Direct tmpR
440                        in  move(opnd1, tmp);
441                            move(opnd2, ecx);
442                            mark(I.BINARY{binOp=opcode, src=ecx, dst=tmp},an);
443                            move(tmp, rdOpnd)
444                        end
445                        else
446                            (move(opnd1, rdOpnd);
447                             move(opnd2, ecx);
448                             mark(I.BINARY{binOp=opcode, src=ecx, dst=rdOpnd},an)
449                            )
450                  end
451    
452    exception EA                    (* Division or remainder: divisor must be in %edx:%eax pair *)
453                  fun divrem(signed, overflow, e1, e2, resultReg) =
454                  let val (opnd1, opnd2) = (operand e1, operand e2)
455                      val _ = move(opnd1, eax)
456                      val oper = if signed then (emit(I.CDQ); I.IDIV)
457                                 else (zero edx; I.UDIV)
458                  in  mark(I.MULTDIV{multDivOp=oper, src=regOrMem opnd2},an);
459                      move(resultReg, rdOpnd);
460                      if overflow then trap() else ()
461                  end
462    
463                      (* Optimize the special case for division *)
464                  fun divide(signed, overflow, e1, e2 as T.LI n) =
465                  let fun isPowerOf2 w = Word.andb((w - 0w1), w) = 0w0
466                      fun log2 n =  (* n must be > 0!!! *)
467                          let fun loop(0w1,pow) = pow
468                                | loop(w,pow) = loop(Word.>>(w, 0w1),pow+1)
469                          in loop(n,0) end
470                      val w = Word.fromInt n
471                  in  if n > 1 andalso isPowerOf2 w then
472                         let val pow = T.LI(log2 w)
473                         in  if signed then
474                             (* signed; simulate round towards zero *)
475                             let val label = Label.newLabel ""
476                                 val reg1  = expr e1
477                                 val opnd1 = I.Direct reg1
478                             in  if setZeroBit e1 then ()
479                                 else emit(I.CMPL{lsrc=opnd1, rsrc=I.Immed 0});
480                                 emit(I.JCC{cond=I.GE, opnd=immedLabel label});
481                                 emit(if n = 2 then
482                                         I.UNARY{unOp=I.INCL, opnd=opnd1}
483                                      else
484                                         I.BINARY{binOp=I.ADDL,
485                                                  src=I.Immed(toInt32 n - 1),
486                                                  dst=opnd1});
487                                 defineLabel label;
488                                 shift(I.SARL, T.REG(32, reg1), pow)
489                             end
490                             else (* unsigned *)
491                                shift(I.SHRL, e1, pow)
492                         end
493                      else
494                           (* note the only way we can overflow is if
495                            * n = 0 or n = -1
496                            *)
497                         divrem(signed, overflow andalso (n = ~1 orelse n = 0),
498                                e1, e2, eax)
499                  end
500                    | divide(signed, overflow, e1, e2) =
501                        divrem(signed, overflow, e1, e2, eax)
502    
503    (* return an index computation *)                fun rem(signed, overflow, e1, e2) =
504    fun index(arg as (T.SLL(_, t, T.LI n))) =                      divrem(signed, overflow, e1, e2, edx)
       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)  
505    
506      fun combineBase(tree, base) =                    (* unsigned integer multiplication *)
507        SOME(case base                fun uMultiply(e1, e2) =
508             of NONE => reduceReg tree                    (* note e2 can never be (I.Direct edx) *)
509              | SOME base => reduceReg(T.ADD(32, T.REG(32,base), tree))                    (move(operand e1, eax);
510             (*esac*))                     mark(I.MULTDIV{multDivOp=I.UMUL,
511                                      src=regOrMem(operand e2)},an);
512                       move(eax, rdOpnd)
513                      )
514    
515      (* keep building a bigger and bigger effective address expressions *)                    (* signed integer multiplication:
516      fun doEA(T.LI n, mode) = newDisp(n, doImmed, mode)                     * The only forms that are allowed that also sets the
517        | doEA(T.LABEL le, mode) = newDisp(le, doLabel, mode)                     * OF and CF flags are:
518        | doEA(T.CONST c, mode) = newDisp(c, doConst, mode)                     *
519        | doEA(t0 as T.SLL(_, t, T.LI scale), mode) =                     *      imul r32, r32/m32, imm8
520          if scale >= 1 andalso scale <= 3 then                     *      imul r32, imm8
521           (case mode                     *      imul r32, imm32
522            of I.Displace{base, disp, mem} =>                     *)
523                 I.Indexed                fun multiply(e1, e2) =
524                  {base=SOME base, index=reduceReg t, scale=scale,                let fun doit(i1 as I.Immed _, i2 as I.Immed _, dstR, dst) =
525                   disp=disp, mem=mem}                        (move(i1, dst);
526             | I.Indexed{base, index, scale, disp, mem} =>                         mark(I.MUL3{dst=dstR, src1=i2, src2=NONE},an))
527                I.Indexed{base=combineBase(t0,base),                      | doit(rm, i2 as I.Immed _, dstR, dst) =
528                          index=index, scale=scale, disp=disp, mem=mem}                          doit(i2, rm, dstR, dst)
529             | disp =>                      | doit(imm as I.Immed(i), rm, dstR, dst) =
530                I.Indexed{base=NONE, index=reduceReg t, scale=scale,                         mark(I.MUL3{dst=dstR, src1=rm, src2=SOME i},an)
531                          disp=disp, mem=mem}                      | doit(r1 as I.Direct _, r2 as I.Direct _, dstR, dst) =
532           (*esac*))                        (move(r1, dst);
533                           mark(I.MUL3{dst=dstR, src1=r2, src2=NONE},an))
534                        | doit(r1 as I.Direct _, rm, dstR, dst) =
535                          (move(r1, dst);
536                           mark(I.MUL3{dst=dstR, src1=rm, src2=NONE},an))
537                        | doit(rm, r as I.Direct _, dstR, dst) =
538                           doit(r, rm, dstR, dst)
539                        | doit(rm1, rm2, dstR, dst) =
540                           if equalRd rm2 then
541                           let val tmpR = newReg()
542                               val tmp  = I.Direct tmpR
543                           in move(rm1, tmp);
544                              mark(I.MUL3{dst=tmpR, src1=rm2, src2=NONE},an);
545                              move(tmp, dst)
546                           end
547          else          else
548           (case mode                           (move(rm1, dst);
549            of I.Displace{base, disp, mem} =>                            mark(I.MUL3{dst=dstR, src1=rm2, src2=NONE},an)
550                 I.Displace{base=Option.valOf(combineBase(t0, SOME base)),                           )
551                            disp=disp, mem=mem}                    val (opnd1, opnd2) = (operand e1, operand e2)
552             | I.Indexed{base, index, scale, disp, mem} =>                in  if isMemReg rd then (* destination must be a real reg *)
553                 I.Indexed{base=combineBase(t0, base),                    let val tmpR = newReg()
554                           index=index, scale=scale, disp=disp, mem=mem}                        val tmp  = I.Direct tmpR
555             | disp => I.Displace{base=reduceReg(t0), disp=disp, mem=mem}                    in  doit(opnd1, opnd2, tmpR, tmp);
556           (*esac*))                        move(tmp, rdOpnd)
557        | doEA(T.ADD(_, t1, t2 as T.REG _), mode) = doEA(t1, doEA(t2, mode))                    end
558        | doEA(T.ADD(_, t1, t2), mode) = doEA(t2, doEA(t1, mode))                    else
559        | doEA(T.SUB(ty, t1, T.LI n), mode) = doEA(T.ADD(ty, t1, T.LI (~n)), mode)                        doit(opnd1, opnd2, rd, rdOpnd)
560        | doEA(t, I.Indexed{base, index, scale, disp, mem}) =                end
           I.Indexed{base=combineBase(t, base), index=index, scale=scale,  
                     disp=disp, mem=mem}  
       | doEA(T.REG(_,r), I.Displace{base, disp, mem}) =  
           I.Indexed{base=SOME base, index=r, scale=0, disp=disp, mem=mem}  
       | 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  
      | I.ImmedLabel le => I.LabelEA le  
      | ea => ea  
   end (* ea *)  
561    
562    and operand(T.LI i) = I.Immed(toInt32 i)                   (* Makes sure the destination must be a register *)
563      | operand(T.LI32 w) = I.Immed(wToInt32 w)                fun dstMustBeReg f =
564      | operand(T.CONST c) = I.Const c                    if isMemReg rd then
565      | operand(T.LABEL lab) = I.ImmedLabel lab                    let val tmpR = newReg()
566      | operand(T.REG(_,r)) = I.Direct r                        val tmp  = I.Direct(tmpR)
567      | operand(T.LOAD(32,t,mem)) = ea(t,mem)                    in  f(tmpR, tmp); move(tmp, rdOpnd) end
568      | operand(t) = I.Direct(reduceReg(t))                    else f(rd, rdOpnd)
   
   (* 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, []))  
569    
570    and cond T.LT = I.LT        | cond T.LTU = I.B                   (* Emit a load instruction; makes sure that the destination
571      | cond T.LE = I.LE        | cond T.LEU = I.BE                    * is a register
572      | cond T.EQ = I.EQ        | cond T.NE = I.NE                    *)
573      | cond T.GE = I.GE        | cond T.GEU = I.AE                fun genLoad(mvOp, ea, mem) =
574      | cond T.GT = I.GT        | cond T.GTU = I.A                    dstMustBeReg(fn (_, dst) =>
575                         mark(I.MOVE{mvOp=mvOp, src=address(ea, mem), dst=dst},an))
576    
577                     (* Generate a zero extended loads *)
578                  fun load8(ea, mem) = genLoad(I.MOVZBL, ea, mem)
579                  fun load16(ea, mem) = genLoad(I.MOVZWL, ea, mem)
580                  fun load8s(ea, mem) = genLoad(I.MOVSBL, ea, mem)
581                  fun load16s(ea, mem) = genLoad(I.MOVSWL, ea, mem)
582                  fun load32(ea, mem) = genLoad(I.MOVL, ea, mem)
583    
584   (* reduce an MLRISC statement tree *)                   (* Generate a sign extended loads *)
585    and reduceStm(T.MV(_, rd, exp),an) =  
586        let fun mv src = mark(I.MOVE{mvOp=I.MOVL, src=src, dst=I.Direct rd},an)                   (* Generate setcc instruction:
587        in  case operandRd(exp, rd)                    *  semantics:  MV(rd, COND(_, T.CMP(ty, cc, t1, t2), yes, no))
588            of opnd as I.Direct rd' => if rd'=rd then () else mv opnd                    *)
589             | opnd => mv opnd                fun setcc(ty, cc, t1, t2, yes, no) =
590        end                let val tmpR = newReg()
591      | reduceStm(T.FMV(_, fd, T.FREG(_,fs)),an) =                    val tmp = I.Direct tmpR
592         if fs=fd then () else mark(I.COPY{dst=[fd], src=[fs], tmp=NONE},an)                    (* We create a temporary here just in
593      | reduceStm(T.FMV(_, fd, T.FLOAD(_, t, mem)),an) =                     * case t1 or t2 contains a use of rd.
594         (mark(I.FLD(ea(t,mem)),an); emit(I.FSTP(I.FDirect fd)))                     *)
595      | reduceStm(T.FMV(_, fd, e),an) =                in  (* Clear the destination first.
596         (reduceFexp(e,an); emit(I.FSTP(I.FDirect fd)))                     * This this because stupid SETcc
597      | reduceStm(T.CCMV(0, exp),an) = reduceCC(exp, 0, an)                     * only writes to the low order
598      | reduceStm(T.CCMV _,_) = error "reduceStm: CCMV"                     * byte.  That's Intel architecture, folks.
599      | reduceStm(T.COPY(_, dst as [_], src),an) =                     *)
600          mark(I.COPY{dst=dst, src=src, tmp=NONE},an)                    zero tmp;
601      | reduceStm(T.COPY(_, dst, src),an) =                    case (yes, no) of
602          mark(I.COPY{dst=dst, src=src, tmp=SOME(I.Direct(newReg()))},an)                      (1, 0) => (* normal case *)
603      | reduceStm(T.FCOPY(_, dst, src),an) =                      let val cc = cmp(true, ty, cc, t1, t2, [])
604          mark(I.FCOPY{dst=dst, src=src, tmp=SOME(I.FDirect(newFreg()))},an)                      in  mark(I.SET{cond=cond cc, opnd=tmp}, an) end
605      | reduceStm(T.JMP(T.LABEL lexp, labs),an) =                    | (0, 1) => (* flip *)
606          mark(I.JMP(I.ImmedLabel lexp, labs),an)                      let val cc = cmp(true, ty,
607      | reduceStm(T.JMP(exp, labs),an) = mark(I.JMP (operand exp, labs),an)                                       T.Basis.negateCond cc, t1, t2, [])
608      | reduceStm(T.CALL(t,def,use,mem),an) =                      in  mark(I.SET{cond=cond cc, opnd=tmp}, an) end
609        let val addCCreg = C.addCell C.CC                    | (C1, C2)  =>
610            fun addList([], acc) = acc                      (* general case;
611              | addList(T.GPR(T.REG(_,r))::regs, acc) =                       * from the Intel optimization guide p3-5 *)
612                   addList(regs, C.addReg(r, acc))                      let val C1 = toInt32 C1
613              | addList(T.FPR(T.FREG(_,r))::regs, acc) =                          val C2 = toInt32 C2
614                   addList(regs, C.addFreg(r, acc))                          val cc = cmp(true, ty, cc, t1, t2, [])
615              | addList(T.CCR(T.CC cc)::regs, acc) =                      in  emit(I.SET{cond=cond cc, opnd=tmp});
616                   addList(regs, addCCreg(cc, acc))                          case Int32.abs(C1-C2)-1 of
617              | addList(_::regs, acc) = addList(regs, acc)                            D as (1 | 2 | 4 | 8) =>
618        in  mark(I.CALL(operand t,                            let val addr = I.Indexed{base=SOME tmpR,
619                        addList(def,C.empty),addList(use,C.empty),mem),an)                                                     index=tmpR,
620        end                                                     scale=Int32.toInt D,
621      | reduceStm(T.RET,an) = mark(I.RET NONE,an)                                                     disp=I.Immed(C1-C2),
622      | reduceStm(T.STORE(8, t1, t2, mem),an) =                                                     mem=readonly}
623        let val opnd = immedOrReg(operand t2)                            in  mark(I.LEA{r32=tmpR, addr=addr}, an) end
624            val src =                          | _ =>
625              (case opnd                           (emit(I.UNARY{unOp=I.DECL, opnd=tmp});
626               of I.Direct r =>                            emit(I.BINARY{binOp=I.ANDL,
627                    if r = C.eax then opnd else (move(opnd,eax,[]); eax)                                          src=I.Immed(C2-C1), dst=tmp});
628                | _ => opnd                            mark(I.BINARY{binOp=I.ADDL,
629               (*esac*))                                          src=I.Immed(Int32.min(C1,C2)),
630        in  mark(I.MOVE{mvOp=I.MOVB, src=src, dst=ea(t1,mem)},an)                                          dst=tmp}, an)
631                             )
632                        end;
633                      move(tmp, rdOpnd)
634                  end (* setcc *)
635    
636                      (* Generate cmovcc instruction.
637                       * on Pentium Pro and Pentium II only
638                       *)
639                  fun cmovcc(ty, cc, t1, t2, yes, no) =
640                  let fun genCmov(dstR, _) =
641                      let val _ = doExpr(no, dstR, []) (* false branch *)
642                          val cc = cmp(true, ty, cc, t1, t2, [])  (* compare *)
643                      in  mark(I.CMOV{cond=cond cc, src=operand yes, dst=dstR}, an)
644                      end
645                  in  dstMustBeReg genCmov
646                  end
647    
648                  fun unknownExp exp = doExpr(Gen.compileRexp exp, rd, an)
649    
650                      (* Generate addition *)
651                  fun addition(e1, e2) =
652                    (dstMustBeReg(fn (dstR, _) =>
653                        mark(I.LEA{r32=dstR, addr=address(exp, readonly)}, an))
654                    handle EA => binaryComm(I.ADDL, e1, e2))
655    
656                      (* Add n to rd *)
657                  fun addN n =
658                    mark(I.BINARY{binOp=I.ADDL, src=I.Immed(toInt32 n),
659                                  dst=rdOpnd}, an)
660    
661              in  case exp of
662                   T.REG(_,rs) =>
663                       if isMemReg rs andalso isMemReg rd then
664                          let val tmp = I.Direct(newReg())
665                          in  move'(MemReg rs, tmp, an);
666                              move'(tmp, rdOpnd, [])
667                          end
668                       else move'(IntReg rs, rdOpnd, an)
669                 | (T.LI 0 | T.LI32 0w0) =>
670                     (* As per Fermin's request, special optimization for rd := 0.
671                      * Currently we don't bother with the size.
672                      *)
673                     if isMemReg rd then move'(I.Immed 0, rdOpnd, an)
674                     else mark(I.BINARY{binOp=I.XORL, src=rdOpnd, dst=rdOpnd}, an)
675                 | T.LI n      => move'(I.Immed(toInt32 n), rdOpnd, an)
676                 | T.LI32 w    => move'(I.Immed(wToInt32 w), rdOpnd, an)
677                 | T.CONST c   => move'(I.ImmedLabel(LE.CONST c), rdOpnd, an)
678                 | T.LABEL lab => move'(I.ImmedLabel lab, rdOpnd, an)
679    
680                   (* 32-bit addition *)
681                 | T.ADD(32, e, (T.LI 1|T.LI32 0w1)) => unary(I.INCL, e)
682                 | T.ADD(32, (T.LI 1|T.LI32 0w1), e) => unary(I.INCL, e)
683                 | T.ADD(32, e, T.LI ~1) => unary(I.DECL, e)
684                 | T.ADD(32, T.LI ~1, e) => unary(I.DECL, e)
685                 | T.ADD(32, e1 as T.REG(_, rs), e2 as T.LI n) =>
686                      if rs = rd then addN n else addition(e1, e2)
687                 | T.ADD(32, e1 as T.LI n, e2 as T.REG(_, rs)) =>
688                      if rs = rd then addN n else addition(e1, e2)
689                 | T.ADD(32, e1, e2) => addition(e1, e2)
690    
691                   (* 32-bit subtraction *)
692                 | T.SUB(32, e, (T.LI 1 | T.LI32 0w1)) => unary(I.DECL, e)
693                 | T.SUB(32, e, T.LI ~1) => unary(I.INCL, e)
694                 | T.SUB(32, (T.LI 0 | T.LI32 0w0), e) => unary(I.NEGL, e)
695    
696                 (* Never mind:
697                   | T.SUB(32, e1, e2 as T.LI n) =>
698                     (mark(I.LEA{r32=rd, addr=address(T.ADD(32, e1, T.LI(~n)),
699                                                      I.Region.readonly)}, an)
700                      handle (Overflow|EA) => binary(I.SUBL, e1, e2))
701                 *)
702                 | T.SUB(32, e1, e2) => binary(I.SUBL, e1, e2)
703    
704                 | T.MULU(32, x, y) => uMultiply(x, y)
705                 | T.DIVU(32, x, y) => divide(false, false, x, y)
706                 | T.REMU(32, x, y) => rem(false, false, x, y)
707    
708                 | T.MULS(32, x, y) => multiply(x, y)
709                 | T.DIVS(32, x, y) => divide(true, false, x, y)
710                 | T.REMS(32, x, y) => rem(true, false, x, y)
711    
712                 | T.ADDT(32, x, y) => (binaryComm(I.ADDL, x, y); trap())
713                 | T.SUBT(32, x, y) => (binary(I.SUBL, x, y); trap())
714                 | T.MULT(32, x, y) => (multiply(x, y); trap())
715                 | T.DIVT(32, x, y) => divide(true, true, x, y)
716                 | T.REMT(32, x, y) => rem(true, true, x, y)
717    
718                 | T.ANDB(32, x, y) => binaryComm(I.ANDL, x, y)
719                 | T.ORB(32, x, y)  => binaryComm(I.ORL, x, y)
720                 | T.XORB(32, x, y) => binaryComm(I.XORL, x, y)
721                 | T.NOTB(32, x)    => unary(I.NOTL, x)
722    
723                 | T.SRA(32, x, y)  => shift(I.SARL, x, y)
724                 | T.SRL(32, x, y)  => shift(I.SHRL, x, y)
725                 | T.SLL(32, x, y)  => shift(I.SHLL, x, y)
726    
727                 | T.LOAD(8, ea, mem) => load8(ea, mem)
728                 | T.LOAD(16, ea, mem) => load16(ea, mem)
729                 | T.LOAD(32, ea, mem) => load32(ea, mem)
730                 | T.CVTI2I(_,T.SIGN_EXTEND,_,T.LOAD(8,ea,mem)) => load8s(ea, mem)
731                 | T.CVTI2I(_,T.SIGN_EXTEND,_,T.LOAD(16,ea,mem)) => load16s(ea, mem)
732    
733                 | T.COND(32, T.CMP(ty, cc, t1, t2), T.LI yes, T.LI no) =>
734                     setcc(ty, cc, t1, t2, yes, no)
735                 | T.COND(32, T.CMP(ty, cc, t1, t2), yes, no) =>
736                    (case !arch of (* PentiumPro and higher has CMOVcc *)
737                       Pentium => unknownExp exp
738                     | _ => cmovcc(ty, cc, t1, t2, yes, no)
739                    )
740                 | T.LET(s,e) => (doStmt s; doExpr(e, rd, an))
741                 | T.MARK(e, A.MARKREG f) => (f rd; doExpr(e, rd, an))
742                 | T.MARK(e, a) => doExpr(e, rd, a::an)
743                 | T.PRED(e,c) => doExpr(e, rd, A.CTRLUSE c::an)
744                 | T.REXT e => compileRexp (reducer()) {e=e, rd=rd, an=an}
745                   (* simplify and try again *)
746                 | exp => unknownExp exp
747              end (* doExpr *)
748    
749              (* generate an expression and return its result register
750               * If rewritePseudo is on, the result is guaranteed to be in a
751               * non memReg register
752               *)
753          and expr(exp as T.REG(_, rd)) =
754              if isMemReg rd then genExpr exp else rd
755            | expr exp = genExpr exp
756    
757          and genExpr exp =
758              let val rd = newReg() in doExpr(exp, rd, []); rd end
759    
760             (* Compare an expression with zero.
761              * On the x86, TEST is superior to AND for doing the same thing,
762              * since it doesn't need to write out the result in a register.
763              *)
764         and cmpWithZero(cc as (T.EQ | T.NE), e as T.ANDB(ty, a, b))  =
765                (case ty of
766                   8 =>  test(I.TESTB, a, b)
767                 | 16 => test(I.TESTW, a, b)
768                 | 32 => test(I.TESTL, a, b)
769                 | _  => (expr e; ())
770                 ; cc)
771            | cmpWithZero(cc, e) = (expr e; cc)
772    
773              (* Emit a test.
774               *   The available modes are
775               *      r/m, r
776               *      r/m, imm
777               * On selecting the right instruction: TESTL/TESTW/TESTB.
778               * When anding an operand with a constant
779               * that fits within 8 (or 16) bits, it is possible to use TESTB,
780               * (or TESTW) instead of TESTL.   Because x86 is little endian,
781               * this works for memory operands too.  However, with TESTB, it is
782               * not possible to use registers other than
783               * AL, CL, BL, DL, and AH, CH, BH, DH.  So, the best way is to
784               * perform register allocation first, and if the operand registers
785               * are one of EAX, ECX, EBX, or EDX, replace the TESTL instruction
786               * by TESTB.
787               *)
788          and test(testopcode, a, b) =
789              let val (_, opnd1, opnd2) = commuteComparison(T.EQ, true, a, b)
790                  (* translate r, r/m => r/m, r *)
791                  val (opnd1, opnd2) =
792                       if isMemOpnd opnd2 then (opnd2, opnd1) else (opnd1, opnd2)
793              in  emit(testopcode{lsrc=opnd1, rsrc=opnd2})
794        end        end
795      | reduceStm(T.STORE(32, t1, t2, mem),an) =  
796          move(immedOrReg(operand t2), ea(t1,mem), an)           (* generate a condition code expression
797      | reduceStm(T.FSTORE(64, t1, t2, mem),an) =             * The zero is for setting the condition code!
798         (case t2             * I have no idea why this is used.
799           of T.FREG(_,fs) => emit(I.FLD(I.FDirect fs))             *)
800            | e => reduceFexp(e,[])        and doCCexpr(T.CMP(ty, cc, t1, t2), 0, an) =
801          (*esac*);            (cmp(false, ty, cc, t1, t2, an); ())
802          mark(I.FSTP(ea(t1,mem)),an))          | doCCexpr(T.CCMARK(e,A.MARKREG f),rd,an) = (f rd; doCCexpr(e,rd,an))
803      | reduceStm(T.BCC(_, T.CMP(ty, cc as (T.EQ | T.NE), t1, T.LI 0),          | doCCexpr(T.CCMARK(e,a), rd, an) = doCCexpr(e,rd,a::an)
804                        lab), an) =          | doCCexpr(T.CCEXT e, cd, an) =
805        let val opnd1 = operand t1             compileCCexp (reducer()) {e=e, cd=cd, an=an}
806            fun jcc() = mark(I.JCC{cond=cond cc, opnd=immedLabel lab},an)          | doCCexpr _ = error "doCCexpr"
807        in  case t1  
808            of T.ANDB _ => jcc()       and ccExpr e = error "ccExpr"
809             | T.ORB _ =>  jcc()  
810             | T.XORB _ => jcc()            (* generate a comparison and sets the condition code;
811             | T.SRA _ =>  jcc()             * return the actual cc used.  If the flag swapable is true,
812             | T.SRL _ =>  jcc()             * we can also reorder the operands.
813             | T.SLL _ =>  jcc()             *)
814             | _ => (emit(I.CMP{lsrc=opnd1, rsrc=I.Immed 0}); jcc())        and cmp(swapable, ty, cc, t1, t2, an) =
815        end            (case cc of
816      | reduceStm(T.BCC(_, T.CMP(ty, cc, t1, t2), lab), an) =               (T.EQ | T.NE) =>
817        let fun cmpAndBranch(cc, opnd1, opnd2) =                (* Sometimes the comparison is not necessary because
818              (emit(I.CMP{lsrc=opnd1, rsrc=opnd2});                 * the bits are already set!
819               mark(I.JCC{cond=cond cc, opnd=immedLabel lab},an))                 *)
820                  if isZero t1 andalso setZeroBit t2 then cmpWithZero(cc, t2)
821            val (opnd1, opnd2) = (operand t1, operand t2)                else if isZero t2 andalso setZeroBit t1 then cmpWithZero(cc, t1)
822        in  if isImmediate opnd1 andalso isImmediate opnd2 then                     (* == and <> can be reordered *)
823              cmpAndBranch(cc, moveToReg opnd1, opnd2)                else genCmp(ty, true, cc, t1, t2, an)
824            else if isImmediate opnd1 then             |  _ => genCmp(ty, swapable, cc, t1, t2, an)
825              cmpAndBranch(T.Util.swapCond cc, opnd2, opnd1)            )
826            else if isImmediate opnd2 then  
827              cmpAndBranch(cc, opnd1, opnd2)            (* Give a and b which are the operands to a comparison (or test)
828            else case (opnd1, opnd2)             * Return the appropriate condition code and operands.
829             of (_, I.Direct _) => cmpAndBranch(cc, opnd1, opnd2)             *   The available modes are:
830              | (I.Direct _, _) => cmpAndBranch(cc, opnd1, opnd2)             *        r/m, imm
831              | _ => cmpAndBranch(cc, moveToReg opnd1, opnd2)             *        r/m, r
832             (*esac*)             *        r,   r/m
833               *)
834          and commuteComparison(cc, swapable, a, b) =
835              let val (opnd1, opnd2) = (operand a, operand b)
836              in  (* Try to fold in the operands whenever possible *)
837                  case (isImmediate opnd1, isImmediate opnd2) of
838                    (true, true) => (cc, moveToReg opnd1, opnd2)
839                  | (true, false) =>
840                       if swapable then (T.Basis.swapCond cc, opnd2, opnd1)
841                       else (cc, moveToReg opnd1, opnd2)
842                  | (false, true) => (cc, opnd1, opnd2)
843                  | (false, false) =>
844                     (case (opnd1, opnd2) of
845                        (_, I.Direct _) => (cc, opnd1, opnd2)
846                      | (I.Direct _, _) => (cc, opnd1, opnd2)
847                      | (_, _)          => (cc, moveToReg opnd1, opnd2)
848                     )
849              end
850    
851              (* generate a real comparison; return the real cc used *)
852          and genCmp(ty, swapable, cc, a, b, an) =
853              let val (cc, opnd1, opnd2) = commuteComparison(cc, swapable, a, b)
854              in  mark(I.CMPL{lsrc=opnd1, rsrc=opnd2}, an); cc
855        end        end
856      | reduceStm(T.BCC(cc, T.CC(0), lab), an) =  
857          mark(I.JCC{cond=cond cc, opnd=immedLabel lab},an)            (* generate code for jumps *)
858      | reduceStm(T.BCC _,_) = error "reduceStm: BCC"        and jmp(T.LABEL(lexp as LE.LABEL lab), labs, an) =
859      | reduceStm(T.FBCC(_, T.FCMP(fty, fcc, t1, t2), lab),an) =               mark(I.JMP(I.ImmedLabel lexp, [lab]), an)
860            | jmp(T.LABEL lexp, labs, an) = mark(I.JMP(I.ImmedLabel lexp, labs), an)
861            | jmp(ea, labs, an)           = mark(I.JMP(operand ea, labs), an)
862    
863           (* convert mlrisc to cellset:
864            *)
865           and cellset mlrisc =
866               let val addCCReg = C.addCell C.CC
867                   fun g([],acc) = acc
868                     | g(T.GPR(T.REG(_,r))::regs,acc)  = g(regs,C.addReg(r,acc))
869                     | g(T.FPR(T.FREG(_,f))::regs,acc) = g(regs,C.addFreg(f,acc))
870                     | g(T.CCR(T.CC(_,cc))::regs,acc)  = g(regs,addCCReg(cc,acc))
871                     | g(T.CCR(T.FCC(_,cc))::regs,acc)  = g(regs,addCCReg(cc,acc))
872                     | g(_::regs, acc) = g(regs, acc)
873               in  g(mlrisc, C.empty) end
874    
875              (* generate code for calls *)
876          and call(ea, flow, def, use, mem, an) =
877              mark(I.CALL(operand ea,cellset(def),cellset(use),mem),an)
878    
879              (* generate code for integer stores *)
880          and store8(ea, d, mem, an) =
881              let val src = (* movb has to use %eax as source. Stupid x86! *)
882                     case immedOrReg(operand d) of
883                         src as I.Direct r =>
884                           if r = C.eax then src else (move(src, eax); eax)
885                       | src => src
886              in  mark(I.MOVE{mvOp=I.MOVB, src=src, dst=address(ea,mem)},an)
887              end
888          and store16(ea, d, mem, an) = error "store16"
889          and store32(ea, d, mem, an) =
890                move'(immedOrReg(operand d), address(ea, mem), an)
891    
892              (* generate code for branching *)
893          and branch(T.CMP(ty, cc, t1, t2), lab, an) =
894               (* allow reordering of operands *)
895               let val cc = cmp(true, ty, cc, t1, t2, [])
896               in  mark(I.JCC{cond=cond cc, opnd=immedLabel lab}, an) end
897            | branch(T.FCMP(fty, fcc, t1, t2), lab, an) =
898               fbranch(fty, fcc, t1, t2, lab, an)
899            | branch(ccexp, lab, an) =
900               (doCCexpr(ccexp, 0, []);
901                mark(I.JCC{cond=cond(Gen.condOf ccexp), opnd=immedLabel lab}, an)
902               )
903    
904              (* generate code for floating point compare and branch *)
905          and fbranch(fty, fcc, t1, t2, lab, an) =
906        let fun compare() =        let fun compare() =
907            let fun ignoreOrder (T.FREG _) = true            let fun ignoreOrder (T.FREG _) = true
908                  | ignoreOrder (T.FLOAD _) = true                  | ignoreOrder (T.FLOAD _) = true
909                        | ignoreOrder (T.FMARK(e,_)) = ignoreOrder e
910                  | ignoreOrder _ = false                  | ignoreOrder _ = false
911                fun t2t1 () = (reduceFexp(t2,[]); reduceFexp(t1,[]))                in  if ignoreOrder t1 orelse ignoreOrder t2 then
912            in  if ignoreOrder t1 orelse ignoreOrder t2 then t2t1()                         (reduceFexp(fty, t2, []); reduceFexp(fty, t1, []))
913                else (reduceFexp(t1,[]); reduceFexp(t2,[]); emit(I.FXCH))                    else (reduceFexp(fty, t1, []); reduceFexp(fty, t2, []);
914                ;                          emit(I.FXCH{opnd=C.ST(1)}));
915                emit(I.FUCOMPP)                emit(I.FUCOMPP)
916            end            end
917            fun branch() =                fun andil i = emit(I.BINARY{binOp=I.ANDL,src=I.Immed(i),dst=eax})
918            let val eax = I.Direct C.eax                fun xoril i = emit(I.BINARY{binOp=I.XORL,src=I.Immed(i),dst=eax})
919                fun andil i = emit(I.BINARY{binOp=I.AND,src=I.Immed(i),dst=eax})                fun cmpil i = emit(I.CMPL{rsrc=I.Immed(i), lsrc=eax})
               fun xoril i = emit(I.BINARY{binOp=I.XOR,src=I.Immed(i),dst=eax})  
               fun cmpil i = emit(I.CMP{rsrc=I.Immed(i), lsrc=eax})  
920                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)
921                fun sahf() = emit(I.SAHF)                fun sahf() = emit(I.SAHF)
922            in  case fcc                fun branch() =
923                      case fcc
924                of T.==   => (andil 0x4400; xoril 0x4000; j(I.EQ, lab))                of T.==   => (andil 0x4400; xoril 0x4000; j(I.EQ, lab))
925                 | T.?<>  => (andil 0x4400; xoril 0x4000; j(I.NE, lab))                 | T.?<>  => (andil 0x4400; xoril 0x4000; j(I.NE, lab))
926                 | T.?    => (sahf(); j(I.P,lab))                 | T.?    => (sahf(); j(I.P,lab))
# Line 360  Line 936 
936                 | T.?>   => (sahf(); j(I.P,lab); andil 0x4100; j(I.EQ,lab))                 | T.?>   => (sahf(); j(I.P,lab); andil 0x4100; j(I.EQ,lab))
937                 | T.<>   => (andil 0x4400; j(I.EQ,lab))                 | T.<>   => (andil 0x4400; j(I.EQ,lab))
938                 | T.?=   => (andil 0x4400; j(I.NE,lab))                 | T.?=   => (andil 0x4400; j(I.NE,lab))
939                       | _      => error "fbranch"
940               (*esac*)               (*esac*)
           end  
941        in  compare(); emit I.FNSTSW; branch()        in  compare(); emit I.FNSTSW; branch()
942        end        end
     | reduceStm(T.FBCC _,_) = error "reduceStm: FBCC"  
     | reduceStm(T.ANNOTATION(s,a),an) = reduceStm(s,a::an)  
943    
944    and reduceCC(T.CMP(ty, _, t1, t2), 0, an) =        and fld(32, opnd) = I.FLDS opnd
945        let val (opnd1, opnd2) = (operand t1, operand t2)          | fld(64, opnd) = I.FLDL opnd
946        in mark(I.CMP(          | fld _         = error "fld"
947              case (opnd1, opnd2)  
948              of (I.Immed _, _) => {lsrc=moveToReg opnd1, rsrc=opnd2}        and fstp(32, opnd) = I.FSTPS opnd
949               | (I.ImmedLabel _, _) => {lsrc=moveToReg opnd1, rsrc=opnd2}          | fstp(64, opnd) = I.FSTPL opnd
950               | (I.Const _, _) => {lsrc=moveToReg opnd1, rsrc=opnd2}          | fstp _         = error "fstp"
951               | (I.Direct _, _) => {lsrc=opnd1, rsrc=opnd2}  
952               | (_, I.Direct _) => {lsrc=opnd1, rsrc=opnd2}            (* generate code for floating point stores *)
953               | _ => {lsrc=moveToReg opnd1, rsrc=opnd2}),an)        and fstore(fty, ea, d, mem, an) =
954        end            (case d of
955      | reduceCC(T.CCMARK(e,a),rd,an) =               T.FREG(fty, fs) => emit(fld(fty, I.FDirect fs))
956        (case #peek MLRiscAnnotations.MARK_REG a of             | _ => reduceFexp(fty, d, []);
957          SOME f => (f rd; reduceCC(e,rd,an))             mark(fstp(fty, address(ea, mem)), an)
958        | 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)  
   
    (* The shift count can be either an immediate or the ECX register *)  
     fun shift(oper, e1, e2, an) = let  
       val (opnd1, opnd2) = (operand e1, operand e2)  
     in  
       move(opnd1, opndRd, []);  
       case opnd2  
        of I.Immed _ => mark(I.BINARY{binOp=oper, src=opnd2, dst=opndRd},an)  
         | _ => (move(opnd2, ecx, []);  
                 mark(I.BINARY{binOp=oper, src=ecx, dst=opndRd},an))  
       (*esac*);  
       rd  
     end (* shift *)  
   
     (* Divisor must be in EDX:EAX *)  
     fun divide(oper, signed, e1, e2, an) =  
     let val (opnd1, opnd2) = (operand e1, operand e2)  
     in  move(opnd1, eax, []);  
         if signed then emit(I.CDQ) else move(I.Immed(0), edx, []);  
         mark(I.MULTDIV{multDivOp=oper, src=regOrMem opnd2},an);  
         move(eax, opndRd, []);  
         rd  
     end  
959    
960      (* unsigned integer multiplication *)        and fexpr e = error "fexpr"
     fun uMultiply(e1, e2, an) =  
       (* note e2 can never be (I.Direct edx) *)  
       (move(operand e1, eax, []);  
        mark(I.MULTDIV{multDivOp=I.UMUL, src=regOrMem(operand e2)},an);  
        move(eax, opndRd, []);  
        rd)  
961    
962      (* signed integer multiplication *)            (* generate floating point expression and put the result in fd *)
963          and doFexpr(fty, T.FREG(_, fs), fd, an) =
964                (if fs = fd then ()
965                 else mark(I.FCOPY{dst=[fd], src=[fs], tmp=NONE}, an)
966                )
967            | doFexpr(fty, T.FLOAD(fty', ea, mem), fd, an) =
968                let val ea = address(ea, mem)
969                in  mark(fld(fty', ea), an);
970                    emit(fstp(fty, I.FDirect fd))
971                end
972            | doFexpr(fty, e, fd, an) =
973                (reduceFexp(fty, e, []);
974                 mark(fstp(fty, I.FDirect fd), an)
975                )
976    
977      (* The only forms that are allowed that also sets the            (*
978       * OF and CF flags are:             * Generate floating point expression using Sethi-Ullman's scheme:
979       *             * This function evaluates a floating point expression,
980       *      imul r32, r32/m32, imm8             * and put result in %ST(0).
      *            imul r32, imm8  
      *      imul r32, imm32  
981       *)       *)
982      fun multiply(e1, e2, an) = let        and reduceFexp(fty, fexp, an)  =
983        fun doit(i1 as I.Immed _, i2 as I.Immed _) =            let val ST = I.FDirect(C.ST 0)
984              (move(i1, opndRd, []);                val ST1 = I.FDirect(C.ST 1)
             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)  
     end  
   
     fun trap() =  
       (case !trapLabel  
        of NONE => (trapLabel := SOME(Label.newLabel "trap"); trap())  
         | SOME lab => emit(I.JCC{cond=I.O, opnd=I.ImmedLabel(LE.LABEL lab)})  
       (*esac*))  
   in  
     case exp  
      of T.REG(_,rs) => (move(I.Direct rs, opndRd, an); rd)  
       | T.LI n         => (move(I.Immed(toInt32 n), opndRd, an); rd)  
       | T.LI32 w => (move(I.Immed(wToInt32 w), opndRd, an); rd)  
       | T.CONST c => (move(I.Const c, opndRd, an); rd)  
       | T.LABEL lab => (move(I.ImmedLabel lab, opndRd, an); rd)  
       | T.ADD(32, e, T.LI 1) => unary(I.INC, e, an)  
       | T.ADD(32, e, T.LI32 0w1) => unary(I.INC, e, an)  
       | T.ADD(32, e, T.LI ~1) => unary(I.DEC, e, an)  
       | T.ADD(32, e1, e2) =>  
           ((mark(I.LEA{r32=rd, addr=ea(exp,I.Region.readonly)}, an); rd)  
             handle EA => binary(true, I.ADD, e1, e2, an))  
       | T.SUB(32, e, T.LI 1) => unary(I.DEC, e, an)  
       | T.SUB(32, e, T.LI32 0w1)        => unary(I.DEC, e, an)  
       | T.SUB(32, e, T.LI ~1) => unary(I.INC, e, an)  
       | T.SUB(32, e1, e2) => binary(false, I.SUB, e1, e2, an)  
       | T.MULU(32, e1, e2) => uMultiply(e1, e2, an)  
       | T.DIVU(32, e1, e2) => (divide(I.UDIV, false, e1, e2, an))  
       | T.ADDT(32, e1, e2) => (binary(true,I.ADD,e1,e2, an); trap(); rd)  
       | T.MULT(32, e1, e2) => (multiply(e1, e2, an); trap(); rd)  
       | T.SUBT(32, e1, e2) =>  
          (binary(false,I.SUB,e1,e2, an); trap(); rd)  
       | T.DIVT(32, e1, e2) =>  
           (divide(I.IDIV, true, e1, e2, an); trap(); rd)  
       | T.LOAD(32, exp, mem) => (move(ea(exp,mem), opndRd, an); rd)  
       | T.LOAD(8, exp, mem) =>  
           (mark(I.MOVE{mvOp=I.MOVZX, src=ea(exp,mem), dst=opndRd}, an); rd)  
       | T.ANDB(32, e1, e2) => binary(true, I.AND, e1, e2, an)  
       | T.ORB(32, e1, e2) => binary(true, I.OR, e1, e2, an)  
       | T.XORB(32, e1, e2) => binary(true, I.XOR, e1, e2, an)  
       | T.SRA(32, e1, e2) => shift(I.SAR, e1, e2, an)  
       | T.SRL(32, e1, e2) => shift(I.SHR, e1, e2, an)  
       | T.SLL(32, e1, e2) => shift(I.SHL, e1, e2, an)  
       | T.SEQ(stm, rexp)  => (reduceStm(stm,[]); reduceRegRd(rexp, rd, an))  
       | T.MARK(e,a) =>  
         (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)  
985    
986      datatype su_numbers =      datatype su_numbers =
987         LEAF of int         LEAF of int
988       | BINARY of int * su_numbers * su_numbers       | BINARY of int * su_numbers * su_numbers
989       | UNARY of int * su_numbers       | UNARY of int * su_numbers
990    
991                  datatype direction = LEFT | RIGHT
992    
993      fun label(LEAF n) = n      fun label(LEAF n) = n
994        | label(BINARY(n, _, _)) = n        | label(BINARY(n, _, _)) = n
995        | label(UNARY(n, _)) = n        | label(UNARY(n, _)) = n
996    
     datatype direction = LEFT | RIGHT  
   
997     (* Generate tree of sethi-ullman numbers *)     (* Generate tree of sethi-ullman numbers *)
998      fun suBinary(t1, t2) = let                fun suBinary(t1, t2) =
999        val su1 = suNumbering(t1, LEFT)                    let val su1 = suNumbering(t1, LEFT)
1000        val su2 = suNumbering(t2, RIGHT)        val su2 = suNumbering(t2, RIGHT)
1001        val n1 = label su1        val n1 = label su1
1002        val n2 = label su2        val n2 = label su2
1003      in BINARY(if n1=n2 then n1+1 else Int.max(n1, n2), su1, su2)      in BINARY(if n1=n2 then n1+1 else Int.max(n1, n2), su1, su2)
1004      end      end
1005    
1006      and suUnary(t) = let                and suUnary(t) =
1007        val su = suNumbering(t, LEFT)                    let val su = suNumbering(t, LEFT)
1008      in UNARY(label su, su)      in UNARY(label su, su)
1009      end      end
1010    
# Line 561  Line 1019 
1019        | suNumbering(T.FABS(_,t), _) = suUnary(t)        | suNumbering(T.FABS(_,t), _) = suUnary(t)
1020        | suNumbering(T.FNEG(_,t), _) = suUnary(t)        | suNumbering(T.FNEG(_,t), _) = suUnary(t)
1021        | suNumbering(T.CVTI2F _, _) = UNARY(1, LEAF 0)        | suNumbering(T.CVTI2F _, _) = UNARY(1, LEAF 0)
1022                    | suNumbering(T.CVTF2F(_,_,t), _) = suUnary t
1023        | suNumbering(T.FMARK(e,a),x) = suNumbering(e,x)        | suNumbering(T.FMARK(e,a),x) = suNumbering(e,x)
1024                    | suNumbering _ = error "suNumbering"
1025    
1026      fun leafEA(T.FREG(_,f)) = I.FDirect f                fun leafEA(T.FREG(fty, f)) = (fty, I.FDirect f)
1027        | leafEA(T.FLOAD(_, t, mem)) = ea(t,mem)                  | leafEA(T.FLOAD(fty, ea, mem)) = (fty, address(ea, mem))
1028        | leafEA _ = error "leafEA"        | leafEA _ = error "leafEA"
1029    
1030      fun cvti2d(t,an) = let                fun cvti2d(t,an) =
1031        val opnd = operand t                let val opnd = operand t
1032        fun doMemOpnd () =        fun doMemOpnd () =
1033          (emit(I.MOVE{mvOp=I.MOVL, src=opnd, dst=tempMem});          (emit(I.MOVE{mvOp=I.MOVL, src=opnd, dst=tempMem});
1034           mark(I.FILD tempMem,an))           mark(I.FILD tempMem,an))
1035      in                in  case opnd of
1036        case opnd                      I.Direct _ => doMemOpnd()
       of I.Direct _ => doMemOpnd()  
1037         | I.Immed _ => doMemOpnd()         | I.Immed _ => doMemOpnd()
1038         | _ => mark(I.FILD opnd, an)         | _ => mark(I.FILD opnd, an)
1039      end      end
# Line 582  Line 1041 
1041      (* traverse expression and su-number tree *)      (* traverse expression and su-number tree *)
1042      fun gencode(_, LEAF 0, an) = ()      fun gencode(_, LEAF 0, an) = ()
1043        | gencode(T.FMARK(e,a), x, an) = gencode(e, x, a::an)        | gencode(T.FMARK(e,a), x, an) = gencode(e, x, a::an)
1044        | gencode(f, LEAF 1, an) = mark(I.FLD(leafEA f), an)                  | gencode(f, LEAF 1, an) = mark(fld(leafEA f), an)
1045        | gencode(t, BINARY(_, su1, LEAF 0), an) = let                  | gencode(t, BINARY(_, su1, LEAF 0), an) =
1046                      let (* optimize the common case when both operands
1047                           * are equal *)
1048                          fun sameEA(T.FREG(t1, f1), T.FREG(t2, f2)) =
1049                                t1 = t2 andalso f1 = f2
1050                            | sameEA _ = false
1051            fun doit(oper, t1, t2) =            fun doit(oper, t1, t2) =
1052              (gencode(t1, su1, []);              (gencode(t1, su1, []);
1053               mark(I.FBINARY{binOp=oper, src=leafEA t2, dst=ST},an))                            mark(I.FBINARY{binOp=oper,
1054                                             src=if sameEA(t1, t2) then ST
1055                                                 else #2(leafEA t2),
1056                                             dst=ST}, an)
1057                             )
1058          in          in
1059            case t                      case t of
1060            of T.FADD(_, t1, t2) => doit(I.FADD, t1, t2)                         T.FADD(_, t1, t2) => doit(I.FADD, t1, t2)
1061             | T.FMUL(_, t1, t2) => doit(I.FMUL, t1, t2)             | T.FMUL(_, t1, t2) => doit(I.FMUL, t1, t2)
1062             | T.FSUB(_, t1, t2) => doit(I.FSUB, t1, t2)             | T.FSUB(_, t1, t2) => doit(I.FSUB, t1, t2)
1063             | T.FDIV(_, t1, t2) => doit(I.FDIV, t1, t2)             | T.FDIV(_, t1, t2) => doit(I.FDIV, t1, t2)
1064                         | _ => error "gencode.BINARY"
1065          end          end
1066        | gencode(fexp, BINARY(_, su1, su2), an) = let                  | gencode(fexp, BINARY(fty, su1, su2), an) =
1067            fun doit(t1, t2, oper, operP, operRP) = let                    let fun doit(t1, t2, oper, operP, operRP) = let
1068             (* oper[P] =>  ST(1) := ST oper ST(1); [pop]             (* oper[P] =>  ST(1) := ST oper ST(1); [pop]
1069              * operR[P] => ST(1) := ST(1) oper ST; [pop]              * operR[P] => ST(1) := ST(1) oper ST; [pop]
1070              *)              *)
# Line 614  Line 1083 
1083                  val fs = I.FDirect(newFreg())                  val fs = I.FDirect(newFreg())
1084                in                in
1085                  gencode (t2, su2, []);                  gencode (t2, su2, []);
1086                  emit(I.FSTP fs);                            emit(fstp(fty, fs));
1087                  gencode (t1, su1, []);                  gencode (t1, su1, []);
1088                  mark(I.FBINARY{binOp=oper, src=fs, dst=ST}, an)                  mark(I.FBINARY{binOp=oper, src=fs, dst=ST}, an)
1089                end                end
# Line 625  Line 1094 
1094             | T.FMUL(_, t1, t2) => doit(t1, t2, I.FMUL, I.FMULP, I.FMULP)             | T.FMUL(_, t1, t2) => doit(t1, t2, I.FMUL, I.FMULP, I.FMULP)
1095             | T.FSUB(_, t1, t2) => doit(t1, t2, I.FSUB, I.FSUBP, I.FSUBRP)             | T.FSUB(_, t1, t2) => doit(t1, t2, I.FSUB, I.FSUBP, I.FSUBRP)
1096             | T.FDIV(_, t1, t2) => doit(t1, t2, I.FDIV, I.FDIVP, I.FDIVRP)             | T.FDIV(_, t1, t2) => doit(t1, t2, I.FDIV, I.FDIVP, I.FDIVRP)
1097                         | _ => error "gencode.BINARY"
1098          end          end
1099        | gencode(fexp, UNARY(_, LEAF 0), an) =        | gencode(fexp, UNARY(_, LEAF 0), an) =
1100          (case fexp          (case fexp
1101            of T.FABS(_, t) => (emit(I.FLD(leafEA t)); mark(I.FUNARY(I.FABS),an))                      of T.FABS(fty, t) =>
1102             | T.FNEG(_, t) => (emit(I.FLD(leafEA t)); mark(I.FUNARY(I.FCHS),an))                           (emit(fld(leafEA t)); mark(I.FUNARY(I.FABS),an))
1103             | T.CVTI2F(_,_,_,t) => cvti2d(t,an)                       | T.FNEG(fty, t) =>
1104                             (emit(fld(leafEA t)); mark(I.FUNARY(I.FCHS),an))
1105                         | T.CVTI2F(_,_,t) => cvti2d(t,an) (* XXX *)
1106                         | _ => error "gencode.UNARY"
1107           (*esac*))           (*esac*))
1108        | gencode(fexp, UNARY(_, su), an) = let                  | gencode(fexp, UNARY(_, su), an) =
1109            fun doit(oper, t) = (gencode(t, su, []); mark(I.FUNARY(oper),an))                    let fun doit(oper, t) =
1110          in                         (gencode(t, su, []); mark(I.FUNARY(oper),an))
1111            case fexp                    in case fexp
1112             of T.FABS(_, t) => doit(I.FABS, t)             of T.FABS(_, t) => doit(I.FABS, t)
1113              | T.FNEG(_, t) => doit(I.FCHS, t)              | T.FNEG(_, t) => doit(I.FCHS, t)
1114                          | T.CVTF2F(_,_,t) => gencode(t, su, an)
1115              | T.CVTI2F _ => error "gencode:UNARY:cvti2f"              | T.CVTI2F _ => error "gencode:UNARY:cvti2f"
1116                          | _ => error "gencode.UNARY"
1117          end          end
1118                    | gencode _ = error "gencode"
1119    
1120      val labels = suNumbering(fexp, LEFT)      val labels = suNumbering(fexp, LEFT)
1121    in gencode(fexp, labels, an)    in gencode(fexp, labels, an)
1122    end (*reduceFexp*)    end (*reduceFexp*)
1123    
1124        fun doStm s = reduceStm(s,[])            (* generate code for a statement *)
1125        val beginCluster = fn _ => (trapLabel := NONE; beginCluster 0)        and stmt(T.MV(_, rd, e), an) = doExpr(e, rd, an)
1126        val endCluster = fn a =>          | stmt(T.FMV(fty, fd, e), an) = doFexpr(fty, e, fd, an)
1127            | stmt(T.CCMV(ccd, e), an) = doCCexpr(e, ccd, an)
1128            | stmt(T.COPY(_, dst, src), an) = copy(dst, src, an)
1129            | stmt(T.FCOPY(fty, dst, src), an) = fcopy(fty, dst, src, an)
1130            | stmt(T.JMP(ctrl, e, labs), an) = jmp(e, labs, an)
1131            | stmt(T.CALL(e, flow, def, use, cdef, cuse, mem), an) =
1132                 call(e,flow,def,use,mem,an)
1133            | stmt(T.RET _, an) = mark(I.RET NONE, an)
1134            | stmt(T.STORE(8, ea, d, mem), an) = store8(ea, d, mem, an)
1135            | stmt(T.STORE(16, ea, d, mem), an) = store16(ea, d, mem, an)
1136            | stmt(T.STORE(32, ea, d, mem), an) = store32(ea, d, mem, an)
1137            | stmt(T.FSTORE(fty, ea, d, mem), an) = fstore(fty, ea, d, mem, an)
1138            | stmt(T.BCC(ctrl, cc, lab), an) = branch(cc, lab, an)
1139            | stmt(T.DEFINE l, _) = defineLabel l
1140            | stmt(T.ANNOTATION(s, a), an) = stmt(s, a::an)
1141            | stmt(s, _) = doStmts(Gen.compileStm s)
1142    
1143          and doStmt s = stmt(s, [])
1144          and doStmts ss = app doStmt ss
1145    
1146          and beginCluster' _ =
1147             ((* Must be cleared by the client.
1148               * if rewriteMemReg then memRegsUsed := 0w0 else ();
1149               *)
1150              trapLabel := NONE; beginCluster 0)
1151          and endCluster' a =
1152           (case !trapLabel           (case !trapLabel
1153            of NONE => ()            of NONE => ()
1154             | SOME lab => (defineLabel lab; emit(I.INTO))             | SOME(_, lab) => (defineLabel lab; emit(I.INTO))
1155            (*esac*);            (*esac*);
1156            endCluster a)            endCluster(a)
1157    in S.STREAM           )
1158       {  beginCluster= beginCluster,  
1159          endCluster  = endCluster,        and reducer() =
1160          emit        = doStm,            T.REDUCER{reduceRexp    = expr,
1161                        reduceFexp    = fexpr,
1162                        reduceCCexp   = ccExpr,
1163                        reduceStm     = stmt,
1164                        operand       = operand,
1165                        reduceOperand = reduceOpnd,
1166                        addressOf     = fn e => address(e, I.Region.memory), (*XXX*)
1167                        emit          = mark,
1168                        instrStream   = instrStream,
1169                        mltreeStream  = self()
1170                       }
1171    
1172          and self() =
1173              S.STREAM
1174              {  beginCluster= beginCluster',
1175                 endCluster  = endCluster',
1176                 emit        = doStmt,
1177          pseudoOp    = pseudoOp,          pseudoOp    = pseudoOp,
1178          defineLabel = defineLabel,          defineLabel = defineLabel,
1179          entryLabel  = entryLabel,          entryLabel  = entryLabel,
1180          comment     = comment,          comment     = comment,
1181          annotation  = annotation,          annotation  = annotation,
1182          exitBlock   = exitBlock,               exitBlock   = fn mlrisc => exitBlock(cellset mlrisc),
1183          alias       = alias,          alias       = alias,
1184          phi         = phi          phi         = phi
1185       }       }
   end  
1186    
1187      in  self()
1188  end  end
1189    
1190    end (* functor *)
1191    
1192    end (* local *)

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

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