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

SCM Repository

[smlnj] Annotation of /sml/trunk/src/MLRISC/x86/x86.mdl
ViewVC logotype

Annotation of /sml/trunk/src/MLRISC/x86/x86.mdl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1156 - (view) (download)

1 : leunga 746 (*
2 :     * 32bit, x86 instruction set.
3 :     *
4 :     * Note:
5 :     * 1. Segmentation registers and other weird stuff are not modelled.
6 :     * 2. The instruction set that I model is 32-bit oriented.
7 :     * I don't try to fit that 16-bit mode stuff in.
8 :     * 3. BCD arithmetic is missing
9 :     * 4. Multi-precision stuff is incomplete
10 :     * 5. No MMX (maybe we'll add this in later)
11 :     * 6. Slegdehammer extensions from AMD (more later)
12 :     *
13 :     * Allen Leung (leunga@cs.nyu.edu)
14 :     *
15 :     *)
16 :     architecture X86 =
17 :     struct
18 :    
19 :     superscalar (* superscalar machine *)
20 :    
21 :     little endian (* little endian architecture *)
22 :    
23 :     lowercase assembly (* print assembly in lower case *)
24 :    
25 :     (*------------------------------------------------------------------------
26 :     * Note: While the x86 has only 8 integer and 8 floating point registers,
27 :     * the SMLNJ compiler fakes it by assuming that it has 32 integer
28 :     * and 32 floating point registers. That's why we have 32 integer
29 :     * and 32 floating point registers in this description.
30 :     * Probably pseudo memory registers should understood directly by
31 :     * the md tool.
32 :     *
33 :     *------------------------------------------------------------------------*)
34 :    
35 :     storage
36 :     GP = $r[32] of 32 bits
37 :     asm: (fn (0,8) => "%al" | (0,16) => "%ax" | (0,32) => "%eax"
38 :     | (1,8) => "%cl" | (1,16) => "%cx" | (1,32) => "%ecx"
39 :     | (2,8) => "%dl" | (2,16) => "%dx" | (2,32) => "%edx"
40 :     | (3,8) => "%bl" | (3,16) => "%bx" | (3,32) => "%ebx"
41 :     | (4,16) => "%sp" | (4,32) => "%esp"
42 :     | (5,16) => "%bp" | (5,32) => "%ebp"
43 :     | (6,16) => "%si" | (6,32) => "%esi"
44 :     | (7,16) => "%di" | (7,32) => "%edi"
45 :     | (r,_) => "%"^Int.toString r
46 :     )
47 :     | FP = $f[32] of 64 bits
48 :     asm: (fn (f,_) =>
49 :     if f < 8 then "%st("^Int.toString f^")"
50 :     else "%f"^Int.toString f (* pseudo register *)
51 :     )
52 :     | CC = $cc[] of 32 bits aliasing GP asm: "cc"
53 :     | EFLAGS = $eflags[1] of 32 bits asm: "$eflags"
54 :     | FFLAGS = $fflags[1] of 32 bits asm: "$fflags"
55 :     | MEM = $m[] of 8 aggregable bits asm: "mem"
56 :     | CTRL = $ctrl[] asm: "ctrl"
57 :    
58 :     locations
59 :     eax = $r[0]
60 :     and ecx = $r[1]
61 :     and edx = $r[2]
62 :     and ebx = $r[3]
63 :     and esp = $r[4]
64 :     and ebp = $r[5]
65 :     and esi = $r[6]
66 :     and edi = $r[7]
67 :     and stackptrR = $r[4]
68 :     and ST(x) = $f[x]
69 : leunga 775 and ST0 = $f[0]
70 : leunga 746 and asmTmpR = $r[0] (* not used *)
71 :     and fasmTmp = $f[0] (* not used *)
72 :     and eflags = $eflags[0]
73 :    
74 :     (*------------------------------------------------------------------------
75 :     *
76 :     * Representation for various opcodes.
77 :     *
78 :     *------------------------------------------------------------------------*)
79 :     structure Instruction =
80 :     struct
81 :     (* An effective address can be any combination of
82 :     * base + index*scale + disp
83 :     * or
84 :     * B + I*SCALE + DISP
85 :     *
86 :     * where any component is optional. The operand datatype captures
87 :     * all these combinations.
88 :     *
89 :     * DISP == Immed | ImmedLabel | Const
90 :     * B == Displace{base=B, disp=0}
91 :     * B+DISP == Displace{base=B, disp=DISP}
92 :     * I*SCALE+DISP == Indexed{base=NONE,index=I,scale=SCALE,disp=D}
93 :     * B+I*SCALE+DISP == Indexed{base=SOME B,index=I,scale=SCALE,disp=DISP}
94 :     * Note1: The index register cannot be EBP.
95 :     * The disp field must be one of Immed, ImmedLabel, or Const.
96 :     *)
97 :    
98 :     (* Note: Relative is only generated after sdi resolution *)
99 :     datatype operand =
100 :     Immed of Int32.int rtl: int
101 : leunga 775 | ImmedLabel of T.labexp rtl: labexp
102 : leunga 746 | Relative of int (* no semantics given *)
103 : leunga 775 | LabelEA of T.labexp rtl: labexp (* XXX *)
104 : leunga 746 | Direct of $GP rtl: $r[GP]
105 :     (* pseudo memory register for floating point *)
106 :     | FDirect of $FP rtl: $f[FP]
107 :     (* virtual floating point register *)
108 :     | FPR of $FP rtl: $f[FP]
109 :     | ST of $FP rtl: $f[FP]
110 :     (* pseudo memory register *)
111 :     | MemReg of $GP rtl: $r[GP]
112 :     | Displace of {base: $GP, disp:operand, mem:Region.region}
113 :     rtl: $m[$r[base] + disp : mem]
114 :     | Indexed of {base: $GP option, index: $GP, scale:int,
115 :     disp:operand, mem:Region.region}
116 :     rtl: $m[$r[base] + $r[index] << scale + disp : mem]
117 :    
118 :     type addressing_mode = operand
119 :    
120 :     type ea = operand
121 :    
122 :     datatype cond! =
123 :     EQ "e" 0w4 | NE 0w5 | LT "l" 0w12 | LE 0w14 | GT "g" 0w15 | GE 0w13
124 :     | B 0w2 | BE (* below *) 0w6 | A 0w7 | AE (* above *) 0w3
125 :     | C 0w2 | NC (* if carry *) 0w3 | P 0wxa | NP (* if parity *) 0wxb
126 :     | O 0w0 | NO (* overflow *) 0w1
127 :    
128 :     (* LOCK can only be used in front of
129 :     * (Intel ordering, not gasm ordering)
130 :     * ADC, ADD, AND, BT mem, reg/imm
131 :     * BTS, BTR, BTC, OR mem, reg/imm
132 :     * SBB, SUB, XOR mem, reg/imm
133 :     * XCHG reg, mem
134 :     * XCHG mem, reg
135 :     * DEC, INC, NEG, NOT mem
136 :     *)
137 :    
138 :     datatype binaryOp! =
139 : leunga 815 ADDL | SUBL | ANDL | ORL | XORL | SHLL | SARL | SHRL | MULL | IMULL
140 :     | ADCL | SBBL
141 :     | ADDW | SUBW | ANDW | ORW | XORW | SHLW | SARW | SHRW | MULW | IMULW
142 :     | ADDB | SUBB | ANDB | ORB | XORB | SHLB | SARB | SHRB | MULB | IMULB
143 : leunga 746 | BTSW | BTCW | BTRW | BTSL | BTCL | BTRL
144 :     | ROLW | RORW | ROLL | RORL
145 :     | XCHGB | XCHGW | XCHGL
146 :    
147 :     (* Moby need these but I'm not going to handle them in the optimzer
148 :     * until Moby starts generating these things
149 :     *)
150 :     | LOCK_ADCW "lock\n\tadcw"
151 :     | LOCK_ADCL "lock\n\tadcl"
152 :     | LOCK_ADDW "lock\n\taddw"
153 :     | LOCK_ADDL "lock\n\taddl"
154 :     | LOCK_ANDW "lock\n\tandw"
155 :     | LOCK_ANDL "lock\n\tandl"
156 :     | LOCK_BTSW "lock\n\tbtsw"
157 :     | LOCK_BTSL "lock\n\tbtsl"
158 :     | LOCK_BTRW "lock\n\tbtrw"
159 :     | LOCK_BTRL "lock\n\tbtrl"
160 :     | LOCK_BTCW "lock\n\tbtcw"
161 :     | LOCK_BTCL "lock\n\tbtcl"
162 :     | LOCK_ORW "lock\n\torw"
163 :     | LOCK_ORL "lock\n\torl"
164 :     | LOCK_SBBW "lock\n\tsbbw"
165 :     | LOCK_SBBL "lock\n\tsbbl"
166 :     | LOCK_SUBW "lock\n\tsubw"
167 :     | LOCK_SUBL "lock\n\tsubl"
168 :     | LOCK_XORW "lock\n\txorw"
169 :     | LOCK_XORL "lock\n\txorl"
170 :     | LOCK_XADDB "lock\n\txaddb"
171 :     | LOCK_XADDW "lock\n\txaddw"
172 :     | LOCK_XADDL "lock\n\txaddl"
173 : leunga 815
174 :     (* One operand opcodes *)
175 : leunga 1156 datatype multDivOp! =
176 :     IMULL1 "imull" | MULL1 "mull" | IDIVL1 "idivl" | DIVL1 "divl"
177 : leunga 746
178 : leunga 797 datatype unaryOp! = DECL | INCL | NEGL | NOTL
179 :     | DECW | INCW | NEGW | NOTW
180 :     | DECB | INCB | NEGB | NOTB
181 : leunga 746 | LOCK_DECL "lock\n\tdecl"
182 :     | LOCK_INCL "lock\n\tincl"
183 :     | LOCK_NEGL "lock\n\tnegl"
184 :     | LOCK_NOTL "lock\n\tnotl"
185 : leunga 1156
186 :     datatype shiftOp! = SHLDL | SHRDL
187 : leunga 746
188 :     datatype bitOp! = BTW
189 :     | BTL
190 :     | LOCK_BTW "lock\n\tbtw"
191 :     | LOCK_BTL "lock\n\tbtl"
192 :    
193 :     datatype move! = MOVL
194 :     | MOVB
195 :     | MOVW
196 : leunga 815 | MOVSWL (* sx(word) -> long *)
197 :     | MOVZWL (* zx(word) -> long *)
198 :     | MOVSBL (* sx(byte) -> long *)
199 :     | MOVZBL (* zx(byte) -> long *)
200 : leunga 746
201 :     (* The Intel manual is incorrect on the description of FDIV and FDIVR *)
202 :     datatype fbinOp! =
203 :     FADDP | FADDS
204 :     | FMULP | FMULS
205 :     | FCOMS
206 :     | FCOMPS
207 :     | FSUBP | FSUBS (* ST(1) := ST-ST(1); [pop] *)
208 :     | FSUBRP | FSUBRS (* ST(1) := ST(1)-ST; [pop] *)
209 :     | FDIVP | FDIVS (* ST(1) := ST/ST(1); [pop] *)
210 :     | FDIVRP | FDIVRS (* ST(1) := ST(1)/ST; [pop] *)
211 :     | FADDL
212 :     | FMULL
213 :     | FCOML
214 :     | FCOMPL
215 :     | FSUBL (* ST(1) := ST-ST(1); [pop] *)
216 :     | FSUBRL (* ST(1) := ST(1)-ST; [pop] *)
217 :     | FDIVL (* ST(1) := ST/ST(1); [pop] *)
218 :     | FDIVRL (* ST(1) := ST(1)/ST; [pop] *)
219 :    
220 :     datatype fibinOp! =
221 :     FIADDS (0wxde,0) | FIMULS (0wxde,1)
222 :     | FICOMS (0wxde,2) | FICOMPS (0wxde,3)
223 :     | FISUBS (0wxde,4) | FISUBRS (0wxde,5)
224 :     | FIDIVS (0wxde,6) | FIDIVRS (0wxde,7)
225 :     | FIADDL (0wxda,0) | FIMULL (0wxda,1)
226 :     | FICOML (0wxda,2) | FICOMPL (0wxda,3)
227 :     | FISUBL (0wxda,4) | FISUBRL (0wxda,5)
228 :     | FIDIVL (0wxda,6) | FIDIVRL (0wxda,7)
229 :    
230 :     datatype funOp! =
231 :     (* the first byte is always d9; the second byte is listed *)
232 :     FCHS 0wxe0
233 :     | FABS 0wxe1
234 :     | FTST 0wxe4
235 :     | FXAM 0wxe5
236 :     | FPTAN 0wxf2
237 :     | FPATAN 0wxf3
238 :     | FXTRACT 0wxf4
239 :     | FPREM1 0wxf5
240 :     | FDECSTP 0wxf6
241 :     | FINCSTP 0wxf7
242 :     | FPREM 0wxf8
243 :     | FYL2XP1 0wxf9
244 :     | FSQRT 0wxfa
245 :     | FSINCOS 0wxfb
246 :     | FRNDINT 0wxfc
247 :     | FSCALE 0wxfd
248 :     | FSIN 0wxfe
249 :     | FCOS 0wxff
250 :    
251 :     datatype fenvOp! = FLDENV | FNLDENV | FSTENV | FNSTENV
252 :    
253 :     (* Intel floating point precision *)
254 :     datatype fsize = FP32 "s" | FP64 "l" | FP80 "t"
255 :    
256 :     (* Intel integer precision *)
257 :     datatype isize = I8 "8" | I16 "16" | I32 "32" | I64 "64"
258 :    
259 :     end (* Instruction *)
260 :    
261 :     (*------------------------------------------------------------------------
262 :     *
263 :     * Here, I'm going to define the semantics of the instructions
264 :     *
265 :     *------------------------------------------------------------------------*)
266 :     structure RTL =
267 :     struct
268 :    
269 :     (* Get the basis *)
270 :     include "Tools/basis.mdl"
271 :     open Basis
272 :     infix 1 || (* parallel effects *)
273 :     infix 2 := (* assignment *)
274 :    
275 :     (* Some type abbreviations *)
276 :     fun byte x = (x : #8 bits)
277 :     fun word x = (x : #16 bits)
278 :     fun long x = (x : #32 bits)
279 :     fun float x = (x : #32 bits)
280 :     fun double x = (x : #64 bits)
281 :     fun real80 x = (x : #80 bits)
282 :    
283 :     (* Intel register abbreviations *)
284 :     val eax = $r[0] and ecx = $r[1] and edx = $r[2] and ebx = $r[3]
285 :     and esp = $r[4] and ebp = $r[5] and esi = $r[6] and edi = $r[7]
286 :    
287 :     (* Condition codes bits in eflag.
288 :     * Let's give symbolic name for each bit as per the Intel doc.
289 :     *)
290 :     rtl setFlag : #n bits -> #n bits
291 :     fun flag b = andb($eflags[0] >> b, 1)
292 :     val CF = flag 0 and PF = flag 2
293 :     and ZF = flag 6 and SF = flag 7 and OF = flag 11
294 :    
295 :     (* Now gets use the bits to express the conditions. Again from Intel. *)
296 :     (* conditions *) (* aliases *)
297 :     val B = CF == 1 val C = B and NAE = B
298 :     val BE = CF == 1 orelse ZF == 1 val NA = BE
299 :     val E = ZF == 1 val Z = E
300 :     val L = SF <> OF val NGE = L
301 :     val LE = SF <> OF orelse ZF == 1 val NG = LE
302 :     val NB = CF == 0 val AE = NB and NC = NB
303 :     val NBE = CF == 0 andalso ZF == 0 val A = NBE
304 :     val NE = ZF == 0 val NZ = NE
305 :     val NL = SF == OF val GE = NL
306 :     val NLE = ZF == 0 andalso SF == OF val G = NLE
307 :     val NO = OF == 0
308 :     val NP = PF == 0 val PO = NP
309 :     val NS = SF == 0
310 :     val O = OF == 1
311 :     val P = PF == 1 val PE = P
312 :     val S = SF == 1
313 :    
314 :     rtl NOP{} = () (* duh! *)
315 :     rtl LEA{addr, r32} = $r[r32] := addr (* this is completely wrong! XXX *)
316 :    
317 :     (* moves with type conversion *)
318 :     rtl MOVL{src,dst} = dst := long src
319 :     rtl MOVW{src,dst} = dst := word src
320 :     rtl MOVB{src,dst} = dst := byte src
321 :     rtl MOVSWL{src,dst} = dst := long(sx(word src))
322 :     rtl MOVZWL{src,dst} = dst := long(zx(word src))
323 :     rtl MOVSBL{src,dst} = dst := long(sx(byte src))
324 :     rtl MOVZBL{src,dst} = dst := long(zx(byte src))
325 :    
326 :     (* semantics of integer arithmetic;
327 :     * all instructions sets the condition code
328 :     *)
329 :     fun binop typ oper {dst,src} = dst := typ(oper(dst,src))
330 :     fun arith typ oper {dst,src} = dst := typ(oper(dst,src))
331 :     || $eflags[0] := ??? (* XXX *)
332 :     fun unary typ oper {opnd} = opnd := typ(oper opnd)
333 :    
334 :     fun inc x = x + 1
335 :     fun dec x = x - 1
336 :    
337 :     (* I'm too lazy to specify the semantics of these for now *)
338 :     rtl adc sbb bts btc btr rol ror xchg xadd cmpxchg
339 :     : #n bits * #n bits -> #n bits
340 :    
341 :     rtl [ADD,SUB,AND,OR,XOR]^^B = map (arith byte) [(+),(-),andb,orb,xorb]
342 :     rtl [ADD,SUB,AND,OR,XOR]^^W = map (arith word) [(+),(-),andb,orb,xorb]
343 :     rtl [ADD,SUB,AND,OR,XOR]^^L = map (arith long) [(+),(-),andb,orb,xorb]
344 :     rtl [SHR,SHL,SAR]^^B = map (binop byte) [(>>),(<<),(~>>)]
345 :     rtl [SHR,SHL,SAR]^^W = map (binop word) [(>>),(<<),(~>>)]
346 :     rtl [SHR,SHL,SAR]^^L = map (binop long) [(>>),(<<),(~>>)]
347 :     rtl [NEG,NOT,INC,DEC]^^B = map (unary byte) [(~),notb,inc,dec]
348 :     rtl [NEG,NOT,INC,DEC]^^W = map (unary word) [(~),notb,inc,dec]
349 :     rtl [NEG,NOT,INC,DEC]^^L = map (unary long) [(~),notb,inc,dec]
350 :    
351 :    
352 :     rtl [ADC,SBB,BTS,BTC,BTR,ROL,ROR,XCHG]^^B =
353 :     map (arith byte) [adc,sbb,bts,btc,btr,rol,ror,xchg]
354 :     rtl [ADC,SBB,BTS,BTC,BTR,ROL,ROR,XCHG]^^W =
355 :     map (arith word) [adc,sbb,bts,btc,btr,rol,ror,xchg]
356 :     rtl [ADC,SBB,BTS,BTC,BTR,ROL,ROR,XCHG]^^L =
357 :     map (arith long) [adc,sbb,bts,btc,btr,rol,ror,xchg]
358 :    
359 :     fun lockarith typ oper {src,dst}=
360 :     dst := typ(oper(dst,src))
361 :     || Kill $eflags[0] (* XXX *)
362 :     fun lockunary typ oper {opnd} =
363 :     opnd := typ(oper(opnd))
364 :     || Kill $eflags[0] (* XXX *)
365 :    
366 :     rtl LOCK_^^[ADD,SUB,AND,OR,XOR,XADD]^^B =
367 :     map (lockarith byte) [(+),(-),andb,orb,xorb,xadd]
368 :     rtl LOCK_^^[ADD,SUB,AND,OR,XOR,XADD]^^W =
369 :     map (lockarith word) [(+),(-),andb,orb,xorb,xadd]
370 :     rtl LOCK_^^[ADD,SUB,AND,OR,XOR,XADD]^^L =
371 :     map (lockarith long) [(+),(-),andb,orb,xorb,xadd]
372 :     rtl LOCK_^^[ADC,SBB,BTS,BTC,BTR,ROL,ROR,XCHG]^^B =
373 :     map (lockarith byte) [adc,sbb,bts,btc,btr,rol,ror,xchg]
374 :     rtl LOCK_^^[ADC,SBB,BTS,BTC,BTR,ROL,ROR,XCHG]^^W =
375 :     map (lockarith word) [adc,sbb,bts,btc,btr,rol,ror,xchg]
376 :     rtl LOCK_^^[ADC,SBB,BTS,BTC,BTR,ROL,ROR,XCHG]^^L =
377 :     map (lockarith long) [adc,sbb,bts,btc,btr,rol,ror,xchg]
378 :     rtl LOCK_^^[DEC,INC,NEG,NOT]^^L =
379 :     map (lockunary long) [dec,inc,(~),notb]
380 :     rtl LOCK_^^[CMPXCHG]^^B = map (lockarith byte) [cmpxchg]
381 :     rtl LOCK_^^[CMPXCHG]^^W = map (lockarith word) [cmpxchg]
382 :     rtl LOCK_^^[CMPXCHG]^^L = map (lockarith long) [cmpxchg]
383 :    
384 :     (* Multiplication/division *)
385 :     rtl upperMultiply : #n bits * #n bits -> #n bits
386 : leunga 815 rtl MULL1{src} = eax := muls(eax, src) ||
387 :     edx := upperMultiply(eax, src) ||
388 :     $eflags[0] := ???
389 :     rtl IDIVL1{src} = eax := divs(eax, src) ||
390 :     edx := rems(eax, src) ||
391 :     $eflags[0] := ???
392 :     rtl DIVL1{src} = edx := divu(eax, src) ||
393 :     edx := remu(eax, src) ||
394 :     $eflags[0] := ???
395 : leunga 746
396 :     (* test[b,w,l] *)
397 :     rtl TESTB {lsrc,rsrc} = $eflags[0] := setFlag(andb(byte lsrc, rsrc))
398 :     rtl TESTW {lsrc,rsrc} = $eflags[0] := setFlag(andb(word lsrc, rsrc))
399 :     rtl TESTL {lsrc,rsrc} = $eflags[0] := setFlag(andb(long lsrc, rsrc))
400 :    
401 :     (* setcc *)
402 :     fun set cc {opnd} = opnd := byte(cond(cc, 0xff, 0x0))
403 :     rtl SET^^ [EQ,NE,LT,LE,GT,GE,B,BE,A,AE,C,NC,P,NP,O,NO] =
404 :     map set [E ,NE,L, LE,G ,GE,B,BE,A,AE,C,NC,P,NP,O,NO]
405 :    
406 :     (* conditional move *)
407 :     fun cmov cc {src,dst} = if cc then $r[dst] := long src else ()
408 :     rtl CMOV^^ [EQ,NE,LT,LE,GT,GE,B,BE,A,AE,C,NC,P,NP,O,NO] =
409 :     map cmov [E ,NE,L, LE,G ,GE,B,BE,A,AE,C,NC,P,NP,O,NO]
410 :    
411 :     (* push and pops *)
412 :     rtl PUSHL {operand} = $m[esp - 4] := long(operand) || esp := esp - 4
413 :     rtl PUSHW {operand} = $m[esp - 2] := word(operand) || esp := esp - 2
414 :     rtl PUSHB {operand} = $m[esp - 1] := byte(operand) || esp := esp - 1
415 :     rtl POP {operand} = operand := long($m[esp]) || esp := esp + 4
416 :    
417 :     (* semantics of branches and jumps *)
418 :     rtl JMP{operand} = Jmp(long operand)
419 :     fun jcc cc {opnd} = if cc then Jmp(long opnd) else ()
420 :     rtl J^^ [EQ,NE,LT,LE,GT,GE,B,BE,A,AE,C,NC,P,NP,O,NO] =
421 :     map jcc [E ,NE,L, LE,G ,GE,B,BE,A,AE,C,NC,P,NP,O,NO]
422 : leunga 796 rtl CALL{opnd,defs,uses} =
423 :     Call(long opnd) ||
424 :     Kill $cellset[defs] ||
425 :     Use $cellset[uses]
426 : leunga 746
427 :     (* semantics of floating point operators
428 :     * The 3-address fake operators first.
429 :     *)
430 :     fun fbinop typ oper {lsrc, rsrc, dst} = dst := typ(oper(lsrc, rsrc))
431 :     fun funary typ oper {src, dst} = dst := typ(oper src)
432 :     rtl F^^[ADD,SUB,MUL,DIV]^^L = map (fbinop double) f^^[add,sub,mul,div]
433 :     rtl F^^[ADD,SUB,MUL,DIV]^^S = map (fbinop float) f^^[add,sub,mul,div]
434 :     rtl F^^[ADD,SUB,MUL,DIV]^^T = map (fbinop real80) f^^[add,sub,mul,div]
435 :    
436 :     (* semantics of trig/transendental functions are abstract *)
437 :     rtl fsqrt fsin fcos ftan fasin facos fatan fln fexp : #n bits -> #n bits
438 :     rtl F^^[CHS,ABS,SQRT,SIN,COS,TAN,ASIN,ACOS,ATAN,LN,EXP] =
439 :     map (funary real80)
440 :     f^^[neg,abs,sqrt,sin,cos,tan,asin,acos,atan,ln,exp]
441 :     end (* RTL *)
442 :    
443 :     (*------------------------------------------------------------------------
444 :     * Machine Instruction encoding on the x86
445 :     * Because of variable width instructions.
446 :     * We decompose each byte field into a seperate format first, then combine
447 :     * then to form the real instructions
448 :     *------------------------------------------------------------------------*)
449 :     instruction formats 8 bits
450 :     modrm{mod:2, reg:3, rm:3}
451 :     | reg{opc:5, reg:3}
452 :     | sib{ss:2, index:3, base:3}
453 :     | immed8{imm:8}
454 :    
455 :     instruction formats 32 bits
456 :     immed32{imm:32}
457 :    
458 :     (*
459 :     * Variable format instructions
460 :     *)
461 :     instruction formats
462 :     immedOpnd{opnd} =
463 :     (case opnd of
464 :     I.Immed i32 => i32
465 :     | I.ImmedLabel le => lexp le
466 :     | I.LabelEA le => lexp le
467 :     | _ => error "immedOpnd"
468 :     )
469 :     | extension{opc, opnd} = (* generate an extension *)
470 :     (case opnd of
471 :     I.Direct r => modrm{mod=3, reg=opc, rm=r}
472 :     | I.MemReg _ => extension{opc,opnd=memReg opnd}
473 :     | I.FDirect _ => extension{opc,opnd=memReg opnd}
474 :     | I.Displace{base, disp, ...} =>
475 :     let val immed = immedOpnd{opnd=disp}
476 :     in () (* XXX *)
477 :     end
478 :     | I.Indexed{base=NONE, index, scale, disp, ...} => ()
479 :     | I.Indexed{base=SOME b, index, scale, disp, ...} => ()
480 :     | _ => error "immedExt"
481 :     )
482 :    
483 :     instruction formats 16 bits
484 :     encodeST{prefix:8, opc:5, st: $FP 3}
485 :    
486 :     instruction formats
487 :     encodeReg{prefix:8, reg: $GP 3, opnd} =
488 :     (emit prefix; immedExt{opc=reg, opnd=opnd})
489 :     | arith{opc1,opc2,src,dst} =
490 :     (case (src, dst) of
491 :     (I.ImmedLabel le, dst) => arith{opc1,opc2,src=I.Immed(lexp le),dst}
492 :     | (I.LabelEA le, dst) => arith{opc1,opc2,src=I.Immed(lexp le),dst}
493 :     | (I.Immed i,dst) => ()
494 :     | (src, I.Direct r) => encodeReg{prefix=opc1+op3,reg,opnd=src}
495 :     | (I.Direct r,dst) => encodeReg{prefix=opc1+0w1,reg,opnd=dst}
496 :     | _ => error "arith"
497 :     )
498 :    
499 :     (*------------------------------------------------------------------------
500 :     * A bunch of routines for emitting assembly on the x86.
501 :     * This is a headache because the syntax is quite non-orthorgonal.
502 :     * So we have to write some code to help out the md tool
503 :     * Assembly note:
504 :     * Note: we are using the AT&T syntax (for Linux) and not the intel syntax
505 :     * memory operands have the form:
506 :     * section:disp(base, index, scale)
507 :     * Most of the complication is actually in emiting the correct
508 :     * operand syntax.
509 :     *------------------------------------------------------------------------*)
510 :    
511 :     functor Assembly
512 : george 823 (structure MemRegs : MEMORY_REGISTERS where I = Instr
513 : george 889 val memRegBase : CellsBasis.cell option) =
514 : leunga 746 struct
515 : george 823 fun memReg r = MemRegs.memReg {reg=r, base=Option.valOf memRegBase}
516 : leunga 746 fun emitInt32 i =
517 :     let val s = Int32.toString i
518 :     val s = if i >= 0 then s else "-"^String.substring(s,1,size s-1)
519 :     in emit s end
520 :    
521 : george 889 val {low=SToffset, ...} = C.cellRange CellsBasis.FP
522 : leunga 746
523 :     fun emitScale 0 = emit "1"
524 :     | emitScale 1 = emit "2"
525 :     | emitScale 2 = emit "4"
526 :     | emitScale 3 = emit "8"
527 :     | emitScale _ = error "emitScale"
528 :    
529 :     and eImmed(I.Immed (i)) = emitInt32 i
530 :     | eImmed(I.ImmedLabel lexp) = emit_labexp lexp
531 :     | eImmed _ = error "eImmed"
532 :    
533 : george 951
534 : leunga 746 and emit_operand opn =
535 :     case opn of
536 :     I.Immed i => (emit "$"; emitInt32 i)
537 :     | I.ImmedLabel lexp => (emit "$"; emit_labexp lexp)
538 :     | I.LabelEA le => emit_labexp le
539 :     | I.Relative _ => error "emit_operand"
540 :     | I.Direct r => emitCell r
541 :     | I.MemReg r => emit_operand(memReg opn)
542 :     | I.ST f => emitCell f
543 : george 889 | I.FPR f => (emit "%f"; emit(Int.toString(CellsBasis.registerNum f)))
544 : leunga 746 | I.FDirect f => emit_operand(memReg opn)
545 :     | I.Displace{base,disp,mem,...} =>
546 :     (emit_disp disp; emit "("; emitCell base; emit ")";
547 :     emit_region mem)
548 :     | I.Indexed{base,index,scale,disp,mem,...} =>
549 :     (emit_disp disp; emit "(";
550 :     case base of
551 :     NONE => ()
552 :     | SOME base => emitCell base;
553 :     comma();
554 :     emitCell index; comma();
555 :     emitScale scale; emit ")"; emit_region mem)
556 :    
557 : george 889 and emit_operand8(I.Direct r) = emit(CellsBasis.toStringWithSize(r,8))
558 : leunga 746 | emit_operand8 opn = emit_operand opn
559 :    
560 :     and emit_disp(I.Immed 0) = ()
561 :     | emit_disp(I.Immed i) = emitInt32 i
562 :     | emit_disp(I.ImmedLabel lexp) = emit_labexp lexp
563 :     | emit_disp _ = error "emit_disp"
564 :    
565 :     (* The gas assembler does not like the "$" prefix for immediate
566 :     * labels in certain instructions.
567 :     *)
568 :     fun stupidGas(I.ImmedLabel lexp) = emit_labexp lexp
569 :     | stupidGas opnd = (emit "*"; emit_operand opnd)
570 :    
571 :     (* Display the floating point binary opcode *)
572 :     fun isMemOpnd(I.MemReg _) = true
573 :     | isMemOpnd(I.FDirect f) = true
574 :     | isMemOpnd(I.LabelEA _) = true
575 :     | isMemOpnd(I.Displace _) = true
576 :     | isMemOpnd(I.Indexed _) = true
577 :     | isMemOpnd _ = false
578 :     fun chop fbinOp =
579 :     let val n = size fbinOp
580 :     in case Char.toLower(String.sub(fbinOp,n-1)) of
581 :     (#"s" | #"l") => String.substring(fbinOp,0,n-1)
582 :     | _ => fbinOp
583 :     end
584 :    
585 : george 889 fun isST0 (I.ST r) = CellsBasis.registerNum r = 0
586 : leunga 815 | isST0 _ = false
587 : leunga 746
588 :     (* Special syntax for binary operators *)
589 :     fun emit_fbinaryOp(binOp,src,dst) =
590 :     if isMemOpnd src then
591 :     (emit_fbinOp binOp; emit "\t"; emit_operand src)
592 :     else (emit(chop(asm_fbinOp binOp)); emit "\t";
593 : leunga 815 case (isST0 src, isST0 dst) of
594 : leunga 746 (_, true) => (emit_operand src; emit ", %st")
595 :     | (true, _) => (emit "%st, "; emit_operand dst)
596 :     | _ => error "emit_fbinaryOp"
597 :     )
598 :    
599 :     val emit_dst = emit_operand
600 :     val emit_src = emit_operand
601 :     val emit_opnd = emit_operand
602 :     val emit_opnd8 = emit_operand8
603 :     val emit_rsrc = emit_operand
604 :     val emit_lsrc = emit_operand
605 :     val emit_addr = emit_operand
606 :     val emit_src1 = emit_operand
607 :     val emit_ea = emit_operand
608 : leunga 1156 val emit_count = emit_operand
609 : leunga 746 end (* Assembly *)
610 :    
611 :    
612 :     (*------------------------------------------------------------------------
613 :     *
614 :     * Reservation tables and pipeline definitions for scheduling.
615 :     * Faked for now as I don't have to time to look up the definitions
616 :     * from the Intel doc.
617 :     *
618 :     *------------------------------------------------------------------------*)
619 :    
620 :     (* Function units *)
621 :     resource issue and mem and alu and falu and fmul and fdiv and branch
622 :    
623 :     (* Different implementations of cpus *)
624 :     cpu default 2 [2 issue, 2 mem, 1 alu, 1 falu, 1 fmul] (* 2 issue machine *)
625 :    
626 :     (* Definitions of various reservation tables *)
627 :     pipeline NOP _ = [issue]
628 :     and ARITH _ = [issue^^alu]
629 :     and LOAD _ = [issue^^mem]
630 :     and STORE _ = [issue^^mem,mem,mem]
631 :     and FARITH _ = [issue^^falu]
632 :     and FMUL _ = [issue^^fmul,fmul]
633 :     and FDIV _ = [issue^^fdiv,fdiv*50]
634 :     and BRANCH _ = [issue^^branch]
635 :    
636 :     (*------------------------------------------------------------------------
637 :     *
638 :     * Compiler representation of the instruction set.
639 :     *
640 :     *------------------------------------------------------------------------*)
641 :     instruction
642 :     NOP
643 :     asm: ``nop''
644 :     rtl: ``NOP''
645 :    
646 :     | JMP of operand * Label.label list
647 :     asm: ``jmp\t<stupidGas operand>''
648 :     rtl: ``JMP''
649 :    
650 :     | JCC of {cond:cond, opnd:operand}
651 :     asm: ``j<cond>\t<stupidGas opnd>''
652 :     rtl: ``J<cond>''
653 :    
654 : leunga 815 | CALL of {opnd: operand, defs: $cellset, uses: $cellset,
655 : blume 839 return: $cellset, cutsTo: Label.label list, mem: Region.region,
656 :     pops:Int32.int}
657 : leunga 796 asm: ``call\t<stupidGas opnd><mem><
658 :     emit_defs(defs)><
659 :     emit_uses(uses)><
660 : leunga 815 emit_cellset("return",return)><
661 : leunga 796 emit_cutsTo cutsTo>''
662 : leunga 746 rtl: ``CALL''
663 :    
664 :     | ENTER of {src1:operand, src2:operand}
665 :     asm: ``enter\t<emit_operand src1>, <emit_operand src2>''
666 :    
667 :     | LEAVE
668 :     asm: ``leave''
669 :    
670 :     | RET of operand option
671 :     asm: ``ret<case option of NONE => ()
672 :     | SOME e => (emit "\t"; emit_operand e)>''
673 :    
674 :     (* integer *)
675 :     | MOVE of {mvOp:move, src:operand, dst:operand}
676 :     asm: ``<mvOp>\t<src>, <dst>''
677 :     rtl: ``<mvOp>''
678 :    
679 :     | LEA of {r32: $GP, addr: operand}
680 :     asm: ``leal\t<addr>, <r32>''
681 :     rtl: ``LEA''
682 :    
683 :     | CMPL of {lsrc: operand, rsrc: operand}
684 :     asm: ``cmpl\t<rsrc>, <lsrc>''
685 :    
686 :     | CMPW of {lsrc: operand, rsrc: operand}
687 :     ``cmpb\t<rsrc>, <lsrc>''
688 :    
689 :     | CMPB of {lsrc: operand, rsrc: operand}
690 :     ``cmpb\t<rsrc>, <lsrc>''
691 :    
692 :     | TESTL of {lsrc: operand, rsrc: operand}
693 :     asm: ``testl\t<rsrc>, <lsrc>''
694 :     rtl: ``TESTL''
695 :    
696 :     | TESTW of {lsrc: operand, rsrc: operand}
697 :     asm: ``testw\t<rsrc>, <lsrc>''
698 :     rtl: ``TESTW''
699 :    
700 :     | TESTB of {lsrc: operand, rsrc: operand}
701 :     asm: ``testb\t<rsrc>, <lsrc>''
702 :     rtl: ``TESTB''
703 :    
704 :     | BITOP of {bitOp:bitOp, lsrc: operand, rsrc: operand}
705 :     ``<bitOp>\t<rsrc>, <lsrc>''
706 :    
707 :     | BINARY of {binOp:binaryOp, src:operand, dst:operand}
708 :     asm: (case (src,binOp) of
709 :     (I.Direct _, (* tricky business here for shifts *)
710 :     (I.SARL | I.SHRL | I.SHLL |
711 :     I.SARW | I.SHRW | I.SHLW |
712 :     I.SARB | I.SHRB | I.SHLB)) => ``<binOp>\t%cl, <dst>''
713 :     | _ => ``<binOp>\t<src>, <dst>''
714 :     )
715 : leunga 815 (*rtl: ``<binOp>''*)
716 : leunga 1156 | SHIFT of {shiftOp:shiftOp, src:operand, dst:operand, count:operand}
717 :     asm: (case count of (* must be %ecx if it is a register *)
718 :     I.Direct ecx => ``<shiftOp>\t<src>, <dst>''
719 :     | _ => ``<shiftOp>\t<src>, <count>, <dst>''
720 :     )
721 : leunga 746
722 : leunga 797 | CMPXCHG of {lock:bool, sz:isize, src: operand, dst:operand}
723 :     asm: (if lock then ``lock\n\t'' else ();
724 :     ``cmpxchg'';
725 :     case sz of
726 :     I.I8 => ``b''
727 :     | I.I16 => ``w''
728 :     | I.I32 => ``l'';
729 :     ``\t<src>, <dst>''
730 :     )
731 :    
732 : leunga 746 | MULTDIV of {multDivOp:multDivOp, src:operand}
733 :     asm: ``<multDivOp>\t<src>''
734 :    
735 : leunga 815 | MUL3 of {dst: $GP, src2: Int32.int, src1:operand}
736 : leunga 746 (* Fermin: constant operand must go first *)
737 : leunga 1156 asm: ``imull\t$<emitInt32 src2>, <src1>, <dst>''
738 : leunga 746
739 :     | UNARY of {unOp:unaryOp, opnd:operand}
740 :     asm: ``<unOp>\t<opnd>''
741 :     rtl: ``<unOp>''
742 :    
743 :     (* set byte on condition code; note that
744 :     * this only sets the low order byte, so it also
745 :     * uses its operand.
746 :     *)
747 :     | SET of {cond:cond, opnd:operand}
748 :     asm: ``set<cond>\t<emit_opnd8 opnd>''
749 :     rtl: ``SET<cond>''
750 :    
751 :     (* conditional move; Pentium Pro or higher only
752 :     * Destination must be a register.
753 :     *)
754 :     | CMOV of {cond:cond, src:operand, dst: $GP}
755 :     asm: ``cmov<cond>\t<src>, <dst>''
756 :     rtl: ``CMOV<cond>''
757 :    
758 :     | PUSHL of operand
759 :     asm: ``pushl\t<operand>''
760 :     rtl: ``PUSHL''
761 :    
762 :     | PUSHW of operand
763 :     asm: ``pushw\t<operand>''
764 :     rtl: ``PUSHW''
765 :    
766 :     | PUSHB of operand
767 :     asm: ``pushb\t<operand>''
768 :     rtl: ``PUSHB''
769 :    
770 : leunga 815 | PUSHFD (* push $eflags onto stack *)
771 :     ``pushfd''
772 :    
773 :     | POPFD (* pop $eflags onto stack *)
774 :     ``popfd''
775 :    
776 : leunga 746 | POP of operand
777 :     asm: ``popl\t<operand>''
778 :     rtl: ``POP''
779 :    
780 :     | CDQ
781 :     ``cdq''
782 :    
783 :     | INTO
784 :     ``into''
785 :    
786 : george 1009 (* floating *)
787 : leunga 746 | FBINARY of {binOp:fbinOp, src:operand, dst:operand}
788 :     asm: (emit_fbinaryOp(binOp,src,dst))
789 :    
790 :     | FIBINARY of {binOp:fibinOp, src:operand}
791 :     asm: ``<binOp>\t<src>'' (* the implied destination is %ST(0) *)
792 :    
793 :     | FUNARY of funOp
794 :     ``<funOp>''
795 :    
796 :     | FUCOM of operand
797 :     ``fucom\t<operand>''
798 :    
799 :     | FUCOMP of operand
800 :     ``fucomp\t<operand>''
801 :    
802 :     | FUCOMPP
803 :     ``fucompp''
804 :    
805 :     | FCOMPP
806 :     ``fcompp''
807 :    
808 : leunga 1156 | FCOMI of operand
809 :     ``fcomi\t<operand>''
810 :    
811 :     | FCOMIP of operand
812 :     ``fcomip\t<operand>''
813 :    
814 :     | FUCOMI of operand
815 :     ``fucomi\t<operand>''
816 :    
817 :     | FUCOMIP of operand
818 :     ``fucomip\t<operand>''
819 :    
820 : leunga 746 | FXCH of {opnd: $FP}
821 :     ``fxch\t<opnd>''
822 :    
823 :     | FSTPL of operand
824 :     asm: (case operand of
825 :     I.ST _ => ``fstp\t<operand>''
826 :     | _ => ``fstpl\t<operand>''
827 :     )
828 :    
829 :     | FSTPS of operand
830 :     ``fstps\t<operand>''
831 :    
832 :     | FSTPT of operand
833 :     ``fstps\t<operand>''
834 :    
835 :     | FSTL of operand
836 :     asm: (case operand of
837 :     I.ST _ => ``fst\t<operand>''
838 :     | _ => ``fstl\t<operand>''
839 :     )
840 :    
841 :     | FSTS of operand
842 :     ``fsts\t<operand>''
843 :    
844 :     | FLD1
845 :     ``fld1''
846 :    
847 :     | FLDL2E
848 :     ``fldl2e''
849 :    
850 :     | FLDL2T
851 :     ``fldl2t''
852 :    
853 :     | FLDLG2
854 :     ``fldlg2''
855 :    
856 :     | FLDLN2
857 :     ``fldln2''
858 :    
859 :     | FLDPI
860 :     ``fldpi''
861 :    
862 :     | FLDZ
863 :     ``fldz''
864 :    
865 :     | FLDL of operand
866 :     asm: (case operand of
867 :     I.ST _ => ``fld\t<operand>''
868 :     | _ => ``fldl\t<operand>''
869 :     )
870 :    
871 :     | FLDS of operand
872 :     ``flds\t<operand>''
873 :    
874 :     | FLDT of operand
875 :     ``fldt\t<operand>''
876 :    
877 :     | FILD of operand
878 :     ``fild\t<operand>''
879 :    
880 :     | FILDL of operand
881 :     ``fildl\t<operand>''
882 :    
883 :     | FILDLL of operand
884 :     ``fildll\t<operand>''
885 :    
886 :     | FNSTSW
887 :     ``fnstsw''
888 :    
889 :     | FENV of {fenvOp:fenvOp, opnd:operand} (* load/store environment *)
890 :     ``<fenvOp>\t<opnd>''
891 :    
892 :     (* pseudo floating ops *)
893 :     | FMOVE of {fsize:fsize, src:operand, dst:operand}
894 :     ``fmove<fsize>\t<src>, <dst>''
895 :    
896 :     | FILOAD of {isize:isize, ea:operand, dst:operand}
897 :     ``fiload<isize>\t<ea>, <dst>''
898 :    
899 :     | FBINOP of {fsize:fsize,
900 :     binOp:fbinOp, lsrc:operand, rsrc:operand, dst:operand}
901 :     ``<binOp><fsize>\t<lsrc>, <rsrc>, <dst>''
902 :     (* rtl: ``<binOp><fsize>'' *)
903 :    
904 :     | FIBINOP of {isize:isize,
905 :     binOp:fibinOp, lsrc:operand, rsrc:operand, dst:operand}
906 :     ``<binOp><isize>\t<lsrc>, <rsrc>, <dst>''
907 :     (* rtl: ``<binOp><isize>'' *)
908 :    
909 :     | FUNOP of {fsize:fsize, unOp:funOp, src:operand, dst:operand}
910 :     ``<unOp><fsize>\t<src>, <dst>''
911 :     (* rtl: [[unOp fsize]] *)
912 :    
913 : leunga 1156 | FCMP of {i:bool,fsize:fsize, lsrc:operand, rsrc:operand}
914 :     asm: (if i then ``fcmp'' else ``fcmpi''; ``<fsize>\t<lsrc>, <rsrc>'')
915 : leunga 746 (* rtl: [["FCMP" fsize]] *)
916 :    
917 :     (* misc *)
918 : leunga 815 | SAHF (* %flags -> %ah *)
919 : leunga 746 ``sahf''
920 :    
921 : leunga 815 | LAHF (* %ah -> %flags *)
922 :     ``lahf''
923 :    
924 : leunga 746 | SOURCE of {}
925 :     asm: ``source''
926 :     mc: ()
927 :    
928 :     | SINK of {}
929 :     asm: ``sink''
930 :     mc: ()
931 :    
932 :     | PHI of {}
933 :     asm: ``phi''
934 :     mc: ()
935 :    
936 :     (*------------------------------------------------------------------------
937 :     * Some helper routines for the SSA optimizer.
938 :     * These should go away soon.
939 :     *------------------------------------------------------------------------*)
940 :     structure SSA =
941 :     struct
942 : leunga 775 fun operand(ty, I.Immed i) = T.LI(T.I.fromInt32(32,i))
943 : leunga 746 (*| operand(ty, I.ImmedLabel le) = T.LABEL le*)
944 :     | operand(ty, I.Direct r) = T.REG(ty, r)
945 :     | operand _ = error "operand"
946 :     end
947 :     (*------------------------------------------------------------------------
948 :     * Some helper routines for the rewriting module.
949 :     * These should go away soon.
950 :     *------------------------------------------------------------------------*)
951 :     structure Rewrite =
952 :     struct
953 :     fun rewriteOperandUse (rs,rt,opnd) =
954 :     (case opnd
955 :     of I.Direct r => if C.sameColor(r,rs) then I.Direct rt else opnd
956 :     | I.Displace{base, disp, mem} =>
957 :     if C.sameColor(base,rs)
958 :     then I.Displace{base=rt, disp=disp, mem=mem}
959 :     else opnd
960 :     | I.Indexed{base as SOME b, index, scale, disp, mem} => let
961 :     val base'= if C.sameColor(b,rs) then SOME rt else base
962 :     val index'=if C.sameColor(index,rs) then rt else index
963 :     in I.Indexed{base=base', index=index', scale=scale,
964 :     disp=disp, mem=mem}
965 :     end
966 :     | I.Indexed{base, index, scale, disp, mem=mem} =>
967 :     if C.sameColor(index,rs) then
968 :     I.Indexed{base=base, index=rt, scale=scale, disp=disp, mem=mem}
969 :     else opnd
970 :     | _ => opnd
971 :     (*esac*))
972 :    
973 :     fun rewriteOperandDef (rs,rt,opnd as I.Direct r) =
974 :     if C.sameColor(r,rs) then I.Direct rt else opnd
975 :    
976 :     fun frewriteOperandDef(fs,ft,opnd as I.FDirect f) =
977 :     if C.sameColor(f,fs) then I.FDirect ft else opnd
978 :     | frewriteOperandDef(fs,ft,opnd as I.FPR f) =
979 :     if C.sameColor(f,fs) then I.FPR ft else opnd
980 :     | frewriteOperandDef opnd = opnd
981 :    
982 :     fun frewriteOperandUse(fs,ft,opnd as I.FDirect r) =
983 :     if C.sameColor(r,fs) then I.FDirect ft else opnd
984 :     | frewriteOperandUse(fs,ft,opnd as I.FPR r) =
985 :     if C.sameColor(r,fs) then I.FPR ft else opnd
986 :     | frewriteOperandUse(fs,ft, opnd) = opnd
987 :     end
988 :    
989 :     end
990 :    

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