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/compiler/OldCGen/x86/x86.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/OldCGen/x86/x86.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

1 : monnier 16 (* x86.sml,
2 :     * derived from i386.sml
3 :     * by Yngvi Guttesen (ysg@id.dth.dk) and Mark Leone (mleone@cs.cmu.edu)
4 :     *
5 :     * Copyright 1989 by Department of Computer Science,
6 :     * The Technical University of Denmak
7 :     * DK-2800 Lyngby
8 :     *
9 :     *)
10 :    
11 :     functor X86CM (V : X86CODER) : CMACHINE = struct
12 :    
13 :     structure D = X86Spec.ObjDesc
14 :    
15 :     val dtoi = LargeWord.toInt (* convert object descriptor to int *)
16 :    
17 :     structure P = CPS.P
18 :     structure V' :
19 :     sig
20 :    
21 :     type Label = V.Label
22 :    
23 :     datatype Size = SevenBits | (* used only for Immed32 *)
24 :     Byte | Word | Long
25 :    
26 :     datatype EA = Direct of int
27 :     | Displace of int * int
28 :     | Index of int * int * int * Size
29 :     | Immed of int
30 :     | Immed32 of Word32.word
31 :     | Immedlab of Label
32 :     | Floatreg of int
33 :    
34 :     val eax : int (* = 0 *)
35 :     val ebx : int (* = 3 *)
36 :     val ecx : int (* = 1 *)
37 :     val edx : int (* = 2 *)
38 :     val esi : int (* = 6 *)
39 :     val edi : int (* = 7 *)
40 :     val ebp : int (* = 5 *)
41 :     val esp : int (* = 4 *)
42 :    
43 :     end = V
44 :    
45 :     open V'
46 :    
47 :     (************************** Register definitions ******************************
48 :     * The 80386 only has 7 general purpose registers. A stack frame is used
49 :     * to hold other values as needed (see runtime/X86.prim.s), but nothing
50 :     * is ever pushed on the stack, since doing so would invalidate the
51 :     * offsets of values in the stack frame. This file must agree with the
52 :     * following runtime files: X86.prim.s, run_ml.c, ml_state.h, fpregs.h
53 :     *
54 :     * The choice of which values go in registers can make a big (10-20%)
55 :     * speed difference. Instructions that indirect through %esp are 1 byte
56 :     * longer and 1 cycle slower than most other other register indirects, so
57 :     * the stack frame isn't all that fast.
58 :     *)
59 :    
60 :     val tempreg' = eax
61 :     val tempreg = Direct tempreg'
62 :     val tempmem = Displace (esp, 0)
63 :     val tempmem2 = Displace (esp, 4)
64 :     val exnptr = Displace (esp, 8)
65 :     val limitptr = Displace (esp, 12)
66 :     val standardclosure = Displace (esp, 16)
67 :     val standardlink = Displace (esp, 20)
68 :     val storeptr = Displace (esp, 24)
69 :     val varptr = Displace (esp, 28)
70 :     val varptr_indexable = false
71 :     val start_gc = Displace (esp, X86Spec.startgcOffset)
72 :     val mask = Displace (esp, 36)
73 :    
74 :     (* vregs start at Displace(esp,40)
75 :     -- see X86.prim.asm, ml-state.c, ml-state.h
76 :     *)
77 :     val numVregs = 12
78 :     local fun mkvreglist 0 = []
79 :     | mkvreglist n = Displace(esp,(numVregs-n)*4+40) :: mkvreglist (n-1)
80 :     in
81 :     val vregs = mkvreglist numVregs
82 :     end
83 :    
84 :     (* pseudo regs are at 88 and 92 *)
85 :     val pseudoOffset = 88
86 :     val pseudo1 = Displace(esp,88)
87 :     val pseudo2 = Displace(esp,92)
88 :    
89 :     val allocptr' = edi
90 :     val allocptr = Direct allocptr'
91 :     val arithtemps = []
92 :    
93 :     (* ecx must be a misc reg -- see X86.prim.s. *)
94 :     val miscregs = map Direct [ebx, ecx, edx] @ vregs
95 :    
96 :     val standardarg = Direct ebp (* NB: instructions w/ebp are longer *)
97 :     val standardcont = Direct esi
98 :    
99 :     (* All floating point "registers" are caller-save. *)
100 :     val savedfpregs = map Floatreg [0,1,2,3,4,5,6]
101 :     val floatregs = []
102 :    
103 :     (*****************************************************************************)
104 :    
105 :     val comment = V.comment
106 :     val immed = Immed (* make the immediate integer mode *)
107 :     val immed32 = Immed32
108 :     val align = V.align (* ensure that next code is on 4-byte boudary *)
109 :     val mark = V.mark (* insert a gc-tag in the code so that next
110 :     address may be moved into a record. *)
111 :    
112 :     val emitlong = V.emitlong (* put a 4-byte integer literal into the code *)
113 :     exception BadReal of string
114 :     val realconst = V.realconst (* put a floating literal into the code *)
115 :     val emitstring = V.emitstring (* put a literal string into the code
116 :     (just the chars , no descriptor or length) *)
117 :    
118 :     (****************************** Labels ***************************************)
119 :    
120 :     fun newlabel () = Immedlab (V.newlabel ())
121 :     (* create a new label (but don't define it) *)
122 :    
123 :     fun die s = ErrorMsg.impossible ("x86/x86.sml: " ^ s)
124 :    
125 :     fun emitlab (i,Immedlab lab) = V.emitlab (i,lab)
126 :     | emitlab _ = die "emitlab: bad args"
127 :     (* L3: emitlab (k,L2) is equivalent to L3: emitlong (L2+k-L3) *)
128 :    
129 :     fun define (Immedlab lab) = V.define lab
130 :     | define _ = die "define: bad arg"
131 :     (* Associate a label with a point in the code *)
132 :    
133 :     (******************************* Move ****************************************)
134 :    
135 :     fun beginStdFn _ = ()
136 :    
137 :     fun inEA (Direct r, r') = (r = r')
138 :     | inEA (Displace (r, _), r') = (r = r')
139 :     | inEA (Index (r, _, r', _), r'') = (r = r'') orelse (r' = r'')
140 :     | inEA _ = false
141 :    
142 :     fun move (src, dest) =
143 :     if src = dest then ()
144 :     else case (src, dest)
145 :     of (x as Floatreg 0, y as Floatreg y') => V.fst false y
146 :     | (x as Floatreg x', y as Floatreg y') => (V.fld x;
147 :     V.fst true (Floatreg (y'+1)))
148 :     | (Floatreg _, _) => die "move: bad args"
149 :     | (_, Floatreg _) => die "move: bad args"
150 :     | (_, Immed _) => die "move: bad args"
151 :     | (_, Immed32 _) => die "move: bad args"
152 :     | (_, Immedlab _) => die "move: bad args"
153 :     | (x as Immedlab _, y as Direct _) => V.lea (x, y)
154 :     | (x as Immed _ , y) => V.movl (x, y)
155 :     | (x as Immed32 _, y) => V.movl (x, y)
156 :     | (x as Direct _ , y) => V.movl (x, y)
157 :     | (x , y as Direct _) => V.movl (x, y)
158 :     | (x , y) =>
159 :     if inEA (y, tempreg') then die "move: no temporary"
160 :     else (move (x, tempreg); move (tempreg, y))
161 :    
162 :     (*************************** Utility functions *******************************)
163 :     (* three opcode (x,y,z) performs the operation: x opcode y -> z for
164 :     * COMMUTATIVE opcodes.
165 :     * three' opcode cmps (x,y,z) performs the same except now it compensates
166 :     * the result for commutativity.
167 :     *)
168 :     fun three opcode (x, y, z as Direct _) =
169 :     if x=z then opcode (y,z)
170 :     else if y=z then opcode (x,z)
171 :     else if x=y then (move (x,z); opcode (z,z))
172 :     else (move (y,z); opcode (x,z))
173 :     | three opcode (x as Displace _, y as Displace _, z as Displace _) =
174 :     if x=z then (move (y,tempreg); opcode (tempreg,z))
175 :     else if y=z then (move (x,tempreg); opcode (tempreg,z))
176 :     else if x=y then (move (x,tempreg);
177 :     opcode (tempreg,tempreg);
178 :     move (tempreg,z))
179 :     else (move (y,tempreg); opcode (x,tempreg); move (tempreg,z))
180 :     | three opcode (x as Displace _, y, z as Displace _) =
181 :     if x=z then opcode (y,z)
182 :     else (move (x,tempreg); opcode (y,tempreg); move (tempreg,z))
183 :     | three opcode (x, y as Displace _, z as Displace _) =
184 :     if y=z then opcode (x,z)
185 :     else (move (y,tempreg); opcode (x,tempreg); move (tempreg,z))
186 :     | three opcode (x, y, z as Displace _) =
187 :     (move (y, tempreg); opcode (x,tempreg); move (tempreg,z))
188 :     (* NB: This increases code size, but decreases memory traffic. *)
189 :     | three _ _ = die "three: bad args"
190 :    
191 :     fun three' opcode cmps (x, y, z as Direct _) =
192 :     if x=z then (opcode (y,z); cmps z)
193 :     else if y=z then opcode (x,z)
194 :     else (move (y,z); opcode (x,z))
195 :     | three' opcode cmps (x as Displace _, y as Displace _, z as Displace _) =
196 :     if x=z then (move (y,tempreg); opcode (tempreg,z); cmps z)
197 :     else if y=z then (move (x,tempreg); opcode (tempreg,z))
198 :     else (move (y,tempreg); opcode (x,tempreg); move (tempreg,z))
199 :     | three' opcode cmps (x as Displace _, y, z as Displace _) =
200 :     if x=z then (opcode (y,z); cmps z)
201 :     else (move (x,z); opcode (y,z); cmps z)
202 :     | three' opcode _ (x, y as Displace _, z as Displace _) =
203 :     if y=z then opcode (x,z) else (move (y,z); opcode (x,z))
204 :     | three' opcode _ (x, y, z as Displace _) =
205 :     (move (y,z); opcode (x,z))
206 :     | three' _ _ _ = die "three': bad args"
207 :    
208 :    
209 :     (***************************** Memory check **********************************)
210 :     fun decLimit n = V.subl (Immed n,limitptr)
211 :    
212 :     fun testLimit () = V.cmpl (limitptr, allocptr)
213 :    
214 :     (* checkLimit (n, lab):
215 :     * Generate code to see if there is enough free space to allocate n bytes.
216 :     *)
217 :    
218 :     fun checkLimit (max_allocation, lab, mask_value, rlab, fregs) =
219 :     let val lab' = V.newlabel ()
220 :     in
221 :     V.comment ("begin fun, max alloc = "^(Int.toString max_allocation)^"\n");
222 :     if max_allocation >= 4096
223 :     then (V.lea (Displace (allocptr', max_allocation - 4096), tempreg);
224 :     V.cmpl (limitptr, tempreg))
225 :     else ();
226 :     V.jb (Immedlab lab');
227 :     (case fregs of
228 :     [] => (move (mask_value, mask);
229 :     move (lab, tempreg);
230 :     V.jmp start_gc)
231 :     | _ => (let val len = length fregs
232 :     val floatSz = 8
233 :     val desc = dtoi(D.makeDesc(len * floatSz, D.tag_string))
234 :     val retlab = V.newlabel()
235 :     fun forall ([],_,_) = ()
236 :     | forall (freg::rest,i,f) =
237 :     (f (freg,i);
238 :     forall (rest,i+8,f))
239 :     fun deposit (Floatreg 0,i) =
240 :     V.fst false (Displace(allocptr',i))
241 :     | deposit (fr,i) =
242 :     (V.fld fr;
243 :     V.fst true (Displace(allocptr',i)))
244 :     fun restore (Floatreg y',i) =
245 :     (V.fld (Displace(tempreg',i));
246 :     V.fst true (Floatreg (y'+1)))
247 :     fun jump (dest as (Immedlab _)) = V.jra dest
248 :     | jump x = V.jmp x
249 :     in
250 :     (* build fp record *)
251 :     move(Immed desc,Displace(allocptr',0));
252 :     forall (fregs,4,deposit);
253 :     V.addl(Immed 4,allocptr);
254 :    
255 :     (* save it in pseudo1 *)
256 :     move(allocptr,pseudo1);
257 :    
258 :     V.addl(Immed (floatSz * len),allocptr);
259 :     move(mask_value,mask);
260 :     move(Immedlab retlab,tempreg);
261 :     V.jmp start_gc;
262 :    
263 :     V.define retlab;
264 :     move(pseudo1,tempreg);
265 :     forall (fregs,0,restore);
266 :     testLimit();
267 :     jump rlab (* don't know what rlab is *)
268 :     end));
269 :     V.define lab'
270 :     end
271 :    
272 :     (************************* Record manipulation *******************************)
273 :    
274 :     (* record : (EA * CPS.accesspath) list * EA -> unit *)
275 :    
276 :     fun record (vl, z) =
277 :     let open CPS
278 :     fun f (Direct r, SELp(j,p)) = f (Displace (r, j*4), p)
279 :     | f (Immedlab l, p) = (move (Immedlab l, tempreg);
280 :     f (tempreg,p))
281 :     | f (x, OFFp 0) = if x=tempreg
282 :     then V.stos x
283 :     else (move (x,tempreg); V.stos tempreg)
284 :     | f (Direct r, OFFp j) = (V.lea (Displace (r, j*4), tempreg);
285 :     f (tempreg, OFFp 0))
286 :     | f (x,p) = (move (x, tempreg); f (tempreg,p))
287 :     in
288 :     app f vl;
289 :     (case z of
290 :     (Direct _) => V.lea (Displace (allocptr', ~4*(List.length vl-1)), z)
291 :     | _ => (V.lea (Displace (allocptr', ~4*(List.length vl - 1)), tempreg);
292 :     V.movl (tempreg,z)))
293 :     end
294 :    
295 :     fun fprecord(tag,vl,z) =
296 :     let open CPS
297 :     val floatSz = 8
298 :     val tagSz = 4
299 :     val pop = true
300 :     fun allocEA i = Displace(allocptr',i*floatSz+tagSz)
301 :     fun f (_,[]) = ()
302 :     | f (i,(Direct r,SELp(j,OFFp 0))::rest) =
303 :     (V.fld (Displace(r,j*floatSz));
304 :     V.fst pop (allocEA i);
305 :     f (i+1,rest))
306 :     | f (i,(Direct r,SELp(j,p))::rest) = f(i,(Displace(r,j*4),p)::rest)
307 :     | f (i,(Floatreg 0,OFFp 0)::rest) =
308 :     (V.fst (not pop) (allocEA i);
309 :     f(i+1,rest))
310 :     | f (i,(fr as Floatreg _,OFFp 0)::rest) =
311 :     (V.fld fr;
312 :     V.fst pop (allocEA i);
313 :     f(i+1,rest))
314 :     | f (i,(ea,p)::rest) =
315 :     (move(ea,tempreg);
316 :     f(i,(tempreg,p)::rest))
317 :     in
318 :     three V.orl (allocptr, Immed 4, allocptr); (* align *)
319 :     move(tag,Displace(allocptr',0));
320 :     f(0,vl);
321 :     (case z of
322 :     (Direct _) => V.lea (Displace (allocptr',4),z)
323 :     | _ => (V.lea (Displace (allocptr',4),tempreg);
324 :     V.movl(tempreg,z)));
325 :     V.addl(Immed (tagSz + floatSz * List.length vl),allocptr)
326 :     end
327 :    
328 :     fun recordcont _ = ErrorMsg.impossible "record_cont not implemented yet"
329 :    
330 :     (* recordStore (x, y, alwaysBoxed) records a store operation into
331 :     * mem[x+2*(z-1)]. The flag alwaysBoxed is true if the value stored
332 :     * is guaranteed to be boxed.
333 :     *)
334 :     (**
335 :     fun recordStore (x, y, _) = record
336 :     ([(immed(dtoi(D.makeDesc(3, D.tag_record))), CPS.OFFp 0),
337 :     (x, CPS.OFFp 0),
338 :     (y, CPS.OFFp 0),
339 :     (storeptr, CPS.OFFp 0)],
340 :     storeptr)
341 :     **)
342 :    
343 :     (* recordStore assumes tempreg is free *)
344 :     (**)
345 :     fun recordStore (x, y, _) =
346 :     let fun storeListUpdate r =
347 :     (move(r,Displace(allocptr',0));
348 :     move(storeptr,Displace(allocptr',4));
349 :     move(allocptr,storeptr);
350 :     V.addl(Immed 8,allocptr))
351 :     in
352 :     case (x,y) of
353 :     (Direct r,Immed 1) => storeListUpdate x
354 :     | (Direct r,Immed i) =>
355 :     (move(x,tempreg);
356 :     V.addl(Immed (2*(i-1)),tempreg);
357 :     storeListUpdate tempreg)
358 :     | (Direct r1,Direct r2) =>
359 :     (move(y,tempreg);
360 :     V.addl(Immed ~1,tempreg);
361 :     V.addl(tempreg,tempreg);
362 :     V.addl(x,tempreg);
363 :     storeListUpdate tempreg)
364 :     | (Displace _,Immed 1) => storeListUpdate x
365 :     | (Displace _,Immed i) =>
366 :     (move(x,tempreg);
367 :     V.addl(Immed(2*(i-1)),tempreg);
368 :     storeListUpdate tempreg)
369 :     | (Displace _,_) =>
370 :     (move(y,tempreg);
371 :     V.addl(Immed ~1,tempreg);
372 :     V.addl(tempreg,tempreg);
373 :     V.addl(x,tempreg);
374 :     storeListUpdate tempreg)
375 :     | (_,Displace _) =>
376 :     (move(y,tempreg);
377 :     V.addl(Immed ~1,tempreg);
378 :     V.addl(tempreg,tempreg);
379 :     V.addl(x,tempreg);
380 :     storeListUpdate tempreg)
381 :     | _ => die "record store: bad args"
382 :     end
383 :     (**)
384 :    
385 :     (* select (i, x, y) generates code for y <- mem[x+4*i]. *)
386 :     fun select(i, Direct s, y) = move (Displace (s, i*4), y)
387 :     | select(i, x as Displace _, y) = (move (x,tempreg); select(i, tempreg, y))
388 :     | select(i, lab as Immedlab _, y) = (move(lab, tempreg); select(i,tempreg,y))
389 :     | select _ = die "select: bad args"
390 :    
391 :     fun handlepseudo f (x,Immed 1) = f(pseudo1,x)
392 :     | handlepseudo f (x,Immed 3) = f(pseudo2,x)
393 :     | handlepseudo f (x as Direct _,y) =
394 :     (* y contains '1' for pr 1, and '3' for pr 2 *)
395 :     (V.lea(Displace(esp,pseudoOffset-2),tempreg); (* compensate for ints *)
396 :     V.addl(y,tempreg);
397 :     V.addl(y,tempreg);
398 :     f (Displace(tempreg',0),x))
399 :     | handlepseudo f (x,y) =
400 :     (* y contains '1' for pr 1, and '3' for pr 2 *)
401 :     let val temp = allocptr
402 :     in
403 :     V.lea(Displace(esp,pseudoOffset-2),tempreg); (* compensate for ints *)
404 :     V.addl(y,tempreg);
405 :     V.addl(y,tempreg);
406 :     V.push temp; (* can't use esp (w/o fixup) until pop *)
407 :    
408 :     (* fixup esp so x can be accessed; this is a hack *)
409 :     V.addl(Immed 4,Direct esp);
410 :    
411 :     move(x,temp);
412 :     f (Displace(tempreg',0),temp);
413 :    
414 :     V.addl(Immed ~4,Direct esp); (* restore esp for pop *)
415 :     V.pop temp
416 :     end
417 :    
418 :     val loadpseudo = handlepseudo move
419 :     val storepseudo = handlepseudo (fn (x,y) => move(y,x))
420 :    
421 :     (* offset (i, x, y) generates code for y <- x+4*i. *)
422 :     fun offset (i,Direct s,y as Direct _) = V.lea (Displace (s,i*4),y)
423 :     | offset (i,Direct s,y) = (V.lea(Displace(s,i*4),tempreg);
424 :     move (tempreg, y))
425 :     | offset (i,x as Displace _,y as Direct _) = (move (x,tempreg);
426 :     offset (i, tempreg, y))
427 :     | offset (i,x as Displace _,y) = (move (x, tempreg);
428 :     offset (i, tempreg, tempreg);
429 :     move (tempreg, y))
430 :     | offset _ = die "offset: bad args"
431 :    
432 :     (****************** Indexed fetch and store (byte) ***************************)
433 :     (*
434 :     * fetchindexb (x:EA, y:EA, z:EA) fetches a byte: mem[x+z] -> y
435 :     * y CAN be x or z
436 :     *
437 :     * storeindexb (x:EA, y:EA, z:EA) stores a byte: x -> mem[y+z]
438 :     *)
439 :     fun fetchindexb (x, y as Displace _, z) = (fetchindexb (x,tempreg,z);
440 :     move (tempreg,y))
441 :     | fetchindexb (x, y as Direct _, z) =
442 :     (case (x,z)
443 :     of (Direct x', Direct z') => V.movzx (Index (x',0,z',Byte), y)
444 :     | (Direct x', Immed i) => V.movzx (Displace (x', i),y)
445 :     | (Direct x', Displace _) => (V.movl (z, tempreg);
446 :     V.movzx (Index (x',0,tempreg',Byte),y))
447 :     | (Displace _, Direct z') => (V.movl (x, tempreg);
448 :     V.movzx (Index (tempreg',0,z',Byte),y))
449 :     | (Displace _, Immed i) => (V.movl (x, tempreg);
450 :     V.movzx (Displace (tempreg', i), y))
451 :     | (Displace _, Displace _) => (V.movl (x,tempreg);
452 :     V.addl (z,tempreg);
453 :     V.movzx (Displace (tempreg',0),y))
454 :     | _ => die "fetchindexb: bad args")
455 :     | fetchindexb _ = die "fetchindexb: bad args"
456 :    
457 :     (* storeindexb (x,y,z) stores a byte: x -> mem[y+z]
458 :     * The 80386 can only perform byte operations on the al,bl,cl,dl,
459 :     * ah,bh,ch, and dh. When doing byte operations on ebp, esi, and edi
460 :     * (Direct i where i>3) we must use a temporary register.
461 :     *)
462 :     fun storeindexb (x, y, z) =
463 :     let
464 :     (* storeb assumes tempreg is free. *)
465 :     fun storeb (x as Immed _, y) = V.movb (x,y)
466 :     | storeb (x as Direct x', y) =
467 :     if (x' > 3) then (move (x, tempreg); V.movb (tempreg, y))
468 :     else V.movb (x,y)
469 :     | storeb (x, y) = (move (x, tempreg); V.movb (tempreg, y))
470 :    
471 :     (* storeb' assumes tempreg appears in the EA denoted by y. *)
472 :     fun storeb' (x,y) =
473 :     let val ecx = Direct ecx
474 :     fun usetemp (x,y) =
475 :     (V.movl (ecx, tempmem); (* Save ecx in memory. *)
476 :     V.lea (y, tempreg); (* ecx may appear in x and/or y. *)
477 :     move (x, ecx); (* Won't nuke tempreg. *)
478 :     V.movb (ecx, Displace (tempreg',0));
479 :     V.movl (tempmem, ecx))
480 :     in
481 :     case x
482 :     of Immed _ => V.movb (x,y)
483 :     | Direct i => if i > 3 then usetemp (x,y) else V.movb (x,y)
484 :     | _ => usetemp (x,y)
485 :     end
486 :     in
487 :     case (y, z)
488 :     of (Direct y', Direct z') => storeb (x, Index (y',0,z',Byte))
489 :     | (Direct y', Immed i) => storeb (x, Displace (y',i))
490 :     | (Direct y', Displace _) => (V.movl (z,tempreg);
491 :     (* was: storeb (x,Index (y',0,tempreg',Byte)))
492 :     -lfh *)
493 :     storeb' (x,Index (y',0,tempreg',Byte)))
494 :     | (Displace _, Direct z') => (V.movl (y,tempreg);
495 :     storeb' (x,Index (tempreg',0,z',Byte)))
496 :     | (Displace _, Immed i) => (V.movl (y,tempreg);
497 :     storeb' (x,Displace (tempreg',i)))
498 :     | (Displace _, Displace _) => (V.movl (y,tempreg);
499 :     V.addl (z,tempreg);
500 :     storeb' (x,Displace (tempreg',0)))
501 :     | _ => die "storeindexb: bad args"
502 :     end
503 :    
504 :     (************ Indexed fetch and store (word = 4 byte) ************************)
505 :     (* fetchindexl (x,y,z) fetches a word: mem[x+2*(z-1)] -> y
506 :     *
507 :     * storeindexl (x,y,z) stores a word: x -> mem[y+2*(z-1)]
508 :     *)
509 :    
510 :     fun fetchindexl (x, y as Displace _, z) = (fetchindexl (x, tempreg, z);
511 :     move (tempreg, y))
512 :     | fetchindexl (x, y as Direct y', z) =
513 :     (case (x,z)
514 :     of (Direct x', Direct z') => V.movl (Index (x', ~2, z', Word), y)
515 :     | (Direct x', Immed i) => V.movl (Displace (x', 2*(i-1)), y)
516 :     | (Direct x', Displace _) => (V.movl (z,tempreg);
517 :     V.movl (Index (x', ~2, tempreg', Word), y))
518 :     | (Displace _, Direct z') => (V.movl (x,tempreg);
519 :     V.movl (Index (tempreg', ~2, z', Word), y))
520 :     | (Displace _, Immed i) => (V.movl (x,tempreg);
521 :     V.movl (Displace (tempreg', 2*(i-1)), y))
522 :     | (Displace _, Displace _) => (V.movl (z,tempreg);
523 :     V.lea (Index (tempreg',~2,tempreg',Byte),
524 :     tempreg);
525 :     V.addl (x,tempreg);
526 :     V.movl (Displace (tempreg',0), y))
527 :     | (Immedlab _, Direct z') => (move (x,tempreg);
528 :     V.movl (Index (tempreg', ~2, z', Word), y))
529 :     | (Immedlab _, Immed i) => (move (x,tempreg);
530 :     V.movl (Displace (tempreg',2*(i-1)), y))
531 :     | (Immedlab _, Displace _) => (* This is awkward with only 1 temp. *)
532 :     (move (x,tempreg);
533 :     V.addl (z,tempreg);
534 :     V.addl (z,tempreg);
535 :     V.movl (Displace (tempreg',~2), y))
536 :     | _ => die "fetchindexl: bad args")
537 :     | fetchindexl _ = die "fetchindexl: bad args"
538 :    
539 :     (* storeindexl (x,y,z) stores a word: x -> mem[y+2*(z-1)] *)
540 :     fun storeindexl (x, y, z) =
541 :     let
542 :     val ecx = Direct ecx
543 :    
544 :     (* move' assumes tempreg appears in the EA denoted by y. *)
545 :     fun move' (x as Immed _, y) = V.movl (x,y)
546 :     | move' (x as Direct x', y) = V.movl (x,y)
547 :     | move' (x, y) =
548 :     (V.lea (y, tempreg);
549 :     V.movl (ecx, tempmem);
550 :     move (x, ecx); (* This won't nuke tempreg *)
551 :     V.movl (ecx, Displace (tempreg',0));
552 :     V.movl (tempmem, ecx))
553 :     in
554 :     case (y, z)
555 :     of (Direct y', Direct z') => move (x, Index (y', ~2, z', Word))
556 :     | (Direct y', Immed i) => move (x, Displace (y', 2*(i-1)))
557 :     | (Direct y', Displace _) => (move (z, tempreg);
558 :     move' (x, Index (y',~2,tempreg',Word)))
559 :     | (Displace _, Direct z') => (move (y, tempreg);
560 :     move' (x, Index (tempreg',~2,z',Word)))
561 :     | (Displace _, Immed i) => (move (y, tempreg);
562 :     move' (x, Displace (tempreg',2*(i-1))))
563 :     | (Displace _, Displace _) => (move (z, tempreg);
564 :     V.asll (Immed 1, tempreg);
565 :     V.addl (y, tempreg);
566 :     move' (x, Displace (tempreg', ~2)))
567 :     | _ => die "storeindexl: bad args"
568 :     end
569 :    
570 :     (* fetchindexd (x,y,z): y<-mem[x+4*(z-1)] *)
571 :     (* storeindexd (x,y,z): mem[y+4*(z-1)]<-x *)
572 :     local
573 :     exception IndexdEA
574 :     fun indexdEA (Direct x', Direct y') = Index (x', ~4, y', Long)
575 :     | indexdEA (Direct x', Immed i) = Displace (x', 4*(i-1))
576 :     | indexdEA (Direct x', y as Displace _) =
577 :     if x' = tempreg' then die "tempreg in use in indexdEA 1"
578 :     else (V.movl (y, tempreg);
579 :     Index (x', ~4, tempreg', Long))
580 :     | indexdEA (x as Displace _, Direct y') =
581 :     if y' = tempreg' then die "tempreg in use in indexdEA 2"
582 :     else (V.movl (x, tempreg);
583 :     Index (tempreg', ~4, y', Long))
584 :     | indexdEA (x as Displace _, Immed i) = (V.movl (x, tempreg);
585 :     Displace (tempreg', 4*(i-1)))
586 :     | indexdEA (x as Displace _, y as Displace _) = (V.movl (y, tempreg);
587 :     V.asll (Immed 2,tempreg);
588 :     V.addl (x, tempreg);
589 :     Displace (tempreg', ~4))
590 :     | indexdEA _ = raise IndexdEA
591 :     in
592 :     fun fetchindexd (x, y as Floatreg y', z) =
593 :     let val src = indexdEA (x,z)
594 :     handle IndexdEA => die "fetchindexd: bad args"
595 :     in
596 :     V.fld src;
597 :     V.fst true (Floatreg (y'+1))
598 :     end
599 :     | fetchindexd _ = die "fetchindexd: bad args"
600 :    
601 :     fun storeindexd (x as Floatreg x', y, z) =
602 :     let val dest = indexdEA (y,z)
603 :     handle IndexdEA => die "storeindexd: bad args"
604 :     in
605 :     if x' = 0 then V.fst false dest
606 :     else (V.fld x; V.fst true dest)
607 :     end
608 :     | storeindexd _ = die "storeindexd: bad args"
609 :    
610 :     end (* local *)
611 :    
612 :     (******************************** Shifts *************************************)
613 :     (* Only ECX can hold the count in a non-immediate shift.
614 :     * The 80386 only shifts modulo 32 so it is possible that this function
615 :     * will lead to an error.
616 :     *)
617 :     local
618 :     val ecx' = 1
619 :     val ecx = Direct ecx'
620 :     fun checkCnt' i = if i < 0 then die "shift: negative count"
621 :     else Immed (Int.min(i,31))
622 :     fun checkCnt (Immed i,x,y) = (checkCnt' i,x,y)
623 :     | checkCnt (Immed32 i,x,y) = (checkCnt' (Word32.toIntX i),x,y)
624 :     | checkCnt x = x
625 :     fun shift opr (i as Immed _, src, dest) =
626 :     (move (src, dest); opr (i, dest))
627 :     | shift opr (cnt, src, dest as Direct 1) =
628 :     (move (src, tempreg);
629 :     move (cnt, ecx);
630 :     opr (ecx, tempreg);
631 :     move (tempreg, dest))
632 :    
633 :     | shift opr (cnt as Direct 1, src, dest) =
634 :     (move (src, dest); opr (ecx, dest))
635 :    
636 :     | shift opr (cnt, src, dest) =
637 :     (* This code is complicated by the fact that cnt, src, and dest
638 :     may be EAs involving %ecx, and that cnt may equal dest. *)
639 :     (move (src, tempreg);
640 :     move (ecx, tempmem);
641 :     move (cnt, ecx);
642 :     opr (ecx, tempreg);
643 :     move (tempmem, ecx);
644 :     move (tempreg, dest))
645 :     in
646 :     val ashl = (shift V.asll) o checkCnt
647 :     val ashr = (shift V.asrl) o checkCnt
648 :     val lshr = (shift V.lsrl) o checkCnt
649 :     end
650 :    
651 :     (*************************** Arithmetic **************************************)
652 :    
653 :     (****)
654 :     (* We can use lea to speed up additions in which overflow is ignored. *)
655 :     fun add (x, y, z as Direct z') =
656 :     if (x = Immed 1 orelse x = Immed32 0w1) andalso y = z then V.incl z
657 :     else if (y = Immed 1 orelse y = Immed32 0w1) andalso x = z then V.incl z
658 :     else
659 :     (case (x,y)
660 :     of (Direct x', Immed i) => V.lea (Displace (x', i), z)
661 :     | (Immed i, Direct y') => V.lea (Displace (y', i), z)
662 :     | (Direct _,Immed32 _) => three V.addl (x,y,z)
663 :     | (Immed32 _, Direct _) => three V.addl (x,y,z)
664 :     | (Direct x', Direct y') => if x' <> z' andalso y' <> z'
665 :     then V.lea (Index (x', 0, y', Byte), z)
666 :     else three V.addl (x,y,z)
667 :     | _ => three V.addl (x,y,z))
668 :     | add (x,y,z) =
669 :     if (x = Immed 1 orelse x = Immed32 0w1) andalso y = z then V.incl z
670 :     else if (y = Immed 1 orelse y = Immed32 0w1) andalso x = z then V.incl z
671 :     else if x = y then ashl (Immed 1, x, z)
672 :     else three V.addl (x,y,z)
673 :     (****)
674 :    
675 :     (** val add = three V.addl (* for debugging *) **)
676 :     fun addt x = (three V.addl x; V.into ())
677 :    
678 :     fun sub (x, y, z) = let
679 :     fun sub1(x, z) = V.subl(x,z)
680 :     fun sub2(x, y, z) =
681 :     (move (y, tempreg); sub1 (x, tempreg); move (tempreg, z))
682 :     fun sub3(x, y, z) = (move (y, z); sub1 (x, z))
683 :     fun sub4(x, z) = (move (x, tempreg); sub1 (tempreg, z))
684 :     in
685 :     if y = z then
686 :     (case z
687 :     of Direct _ => sub1(x, z)
688 :     | _ => (case x of Displace _ => sub4(x, z) | _ => sub1(x,z))
689 :     (*esac*))
690 :     else
691 :     (case z
692 :     of Direct _ => if x = z then sub2 (x, y, z) else sub3 (x, y, z)
693 :     | _ => sub2 (x, y, z)
694 :     (*esac*))
695 :     end
696 :    
697 :     fun subt x = (sub x; V.into())
698 :    
699 :     (* Can't use LEA here because it doesn't set the overflow flag. *)
700 :     fun mull mulFn (src, dest as Direct _) = mulFn (src, dest)
701 :     | mull mulFn (src, dest) = (move (dest, tempreg);
702 :     mulFn (src, tempreg);
703 :     move (tempreg, dest))
704 :    
705 :     (* On the 80386 signed (unsigned) integer division is done with the IDIV (UDIV)
706 :     instruction. For IDIV, the dividend is sign-extended into EDX:EAX.
707 :     For UDIV, EDX is zero and the dividend is in EAX. The divisor must
708 :     be either a register or a memory location. The quotient is stored
709 :     in EAX (e.g. tempreg) and the remainder in EDX. Hence, we must save
710 :     EDX unless it is the dividend. *)
711 :    
712 :     local val edx' = 2
713 :     val edx = Direct edx'
714 :     in
715 :     fun divl divFn (x as Immed _, y) = (V.movl (x, tempmem);
716 :     divl divFn (tempmem, y))
717 :     | divl divFn (x as Immed32 _, y) = (V.movl (x, tempmem);
718 :     divl divFn (tempmem, y))
719 :     | divl divFn (x, y) =
720 :     let val x = if inEA (x, edx') then (move (x, tempmem); tempmem)
721 :     else x
722 :     in
723 :     V.movl (y, tempreg); (* NB: y may be an EA involving edx. *)
724 :     if y = edx then (* OK to overwrite edx. *)
725 :     (divFn x;
726 :     V.movl (tempreg, y))
727 :     else
728 :     (* We must save edx, since divFn will destroy it.
729 :     We can't push it, since x may be an EA involving esp! *)
730 :     (V.movl (edx, tempmem2);
731 :     divFn x;
732 :     V.movl (tempmem2, edx);
733 :     V.movl (tempreg, y))
734 :     end
735 :     end
736 :    
737 :     fun mult x = (mull V.mullExtend x; V.into ())
738 :     fun divt x = (divl (fn y => (V.cdq(); V.idivl y)) x; V.into ())
739 :    
740 :     (************************** Word32 operations ********************************)
741 :     val mulu = mull V.mull
742 :     val divtu = divl (fn x => (move(Immed 0, Direct edx); V.udivl x))
743 :     (* addu, subu, lshr defined above *)
744 :    
745 :     (************************** Bitwise operations *******************************)
746 :    
747 :     fun notb (a,b) = (move (a,b); V.notl b)
748 :     val orb = three V.orl
749 :     val xorb = three V.xorl
750 :     val andb = three V.andl
751 :    
752 :    
753 :     (*************************** Branches ***************************************)
754 :     fun jmp (lab as Immedlab _) = V.jra lab
755 :     | jmp (x as Direct _) = V.jmp x
756 :     | jmp (x as Displace _) = V.jmp x
757 :     | jmp _ = die "jmp: bad arg"
758 :    
759 :     (* jmpindexb (x,y) (x+y) -> PC *)
760 :     fun jmpindexb (lab as Immedlab _, indx as Direct _) = jmpidx (lab, indx)
761 :     | jmpindexb (lab as Immedlab _, indx as Displace _) = jmpidx (lab, indx)
762 :     | jmpindexb _ = die "jmpindexb: bad arg"
763 :    
764 :     and jmpidx (lab, indx) = (move (lab, tempreg);
765 :     V.addl (indx, tempreg);
766 :     V.jmp tempreg)
767 :    
768 :     datatype condition = NEQ | EQL | LEQ | GEQ | LSS | GTR
769 :     | GEU | GTU | LTU | LEU
770 :    
771 :     fun cbranch NEQ = V.jne
772 :     | cbranch EQL = V.jeq
773 :     | cbranch LEQ = V.jle
774 :     | cbranch GEQ = V.jge
775 :     | cbranch LSS = V.jlt
776 :     | cbranch GTR = V.jgt
777 :     | cbranch GEU = V.jae (* above and equal *)
778 :     | cbranch GTU = V.ja (* above *)
779 :     | cbranch LTU = V.jb (* below *)
780 :     | cbranch LEU = V.jbe (* below and equal *)
781 :    
782 :     fun rev LEQ = GEQ
783 :     | rev GEQ = LEQ
784 :     | rev LSS = GTR
785 :     | rev GTR = LSS
786 :     | rev NEQ = NEQ
787 :     | rev EQL = EQL
788 :     | rev GEU = LEU
789 :     | rev GTU = LTU
790 :     | rev LTU = GTU
791 :     | rev LEU = GEU
792 :    
793 :     (* if op1 <cond> op2 then label -> PC else ()
794 :     * Note that cmpl (op1,op2) is equivalent to flags = op2-op1
795 :     * that is if we want to see if op1 <= op2 we have to make
796 :     * the test cmpl (op2,op1) (op1-op2) and jump on the condition leq
797 :     *)
798 :     fun ibranch (cond, op1 as Displace _, op2 as Displace _, label) =
799 :     (move (op1, tempreg); ibranch (cond, tempreg, op2, label))
800 :     | ibranch (cond, op1 as Immed _, op2 as Immed _, label) =
801 :     (move (op2,tempreg); V.cmpl (op1, tempreg); cbranch (rev cond) label)
802 :     | ibranch (cond, op1 as Immed _, op2, label) =
803 :     (V.cmpl (op1, op2); cbranch (rev cond) label)
804 :     | ibranch (cond, op1 as Immed32 _, op2 as Immed32 _, label) =
805 :     (move (op2,tempreg);
806 :     V.cmpl (op1, tempreg); cbranch (rev cond) label)
807 :     | ibranch (cond, op1 as Immed32 _, op2, label) =
808 :     (V.cmpl (op1, op2); cbranch (rev cond) label)
809 :     | ibranch (cond, op1, op2, label) =
810 :     (V.cmpl (op2,op1); cbranch cond label)
811 :    
812 :     (* bbs (i, dst, lab): test the i'th bit of dst and jump to lab if it is set.
813 :     * This function is only called from one place in GENERIC.SML, and that is
814 :     * as: bbs (immed 0, regbind x, lab); gen a; genlab (lab, b)
815 :     *)
816 :     fun bbs (x as Immed _, y as Direct _ , l) = (V.btst (x,y);
817 :     V.jc l)
818 :     | bbs (x as Immed _, y as Displace _, l) = (V.btst (x,y);
819 :     V.jc l)
820 :     | bbs _ = die "bbs: bad arg"
821 :    
822 :     (************************** Floating point instructions *********************)
823 :    
824 :     (* This code is complicated by the fact that the 80387 coprocessor
825 :     uses a stack of floating point registers. The top of the stack is an
826 :     implicit argument in most floating point instructions. We use seven of
827 :     the eight available stack entries as "registers"; the remaining
828 :     entry (at the top of the stack) is used as a temporary.
829 :     Unfortunately, loading the temporary must be done with a "push",
830 :     which changes the offsets of the other "registers". Note that most
831 :     floating point instructions can optionally pop the register stack. *)
832 :    
833 :     fun loadfloat (x as Direct _, y as Floatreg y') =
834 :     fetchindexd (x, y, Immed 1)
835 :     | loadfloat (x, y as Floatreg y') =
836 :     (move (x, tempreg);
837 :     fetchindexd (tempreg, y, Immed 1))
838 :     | loadfloat _ = die "loadfloat: bad args"
839 :    
840 :     fun storefloat (x as Floatreg x', y) =
841 :     (V.movl (Immed(dtoi D.desc_reald), tempreg);
842 :     V.stos tempreg;
843 :     storeindexd (x, allocptr, Immed 1);
844 :     move (allocptr, y);
845 :     V.addl (Immed 8, allocptr))
846 :     | storefloat _ = die "storefloat: bad args"
847 :    
848 :    
849 :     (* float1 opr (x,y) generates code for y <- opr x. *)
850 :    
851 :     fun float1 opr (x as Floatreg x', y as Floatreg y') =
852 :     if x' = y' andalso y' = 0 then opr ()
853 :     else (V.fld x; opr (); V.fst true (Floatreg (y'+1)))
854 :     | float1 _ _ = die "float1: bad args"
855 :    
856 :     (* float2 opr (x,y) generates code for y <- x opr y. The operator
857 :     takes a boolean that specifies whether to pop the register stack. *)
858 :    
859 :     fun float2 opr (x as Floatreg x', y as Floatreg y') =
860 :     if x' = 0 (* orelse y' = 0 *) then opr false (x, y)
861 :     else (V.fld x; opr true (Floatreg 0, Floatreg (y'+1)))
862 :     | float2 _ _ = die "float2: bad args"
863 :    
864 :     (* float3 opr b (x,y,z) generates code for z <- x opr y. b is a
865 :     boolean specifying whether opr is commutative. The operator takes a
866 :     boolean that specifies whether to pop the register stack. *)
867 :    
868 :     fun float3 opr commut (x as Floatreg x', y as Floatreg y', z as Floatreg z') =
869 :     if x' = z' andalso commut then float2 opr (y, z)
870 :     else if y' = z' then float2 opr (x, z)
871 :     else (V.fld x;
872 :     opr false (Floatreg (y'+1), Floatreg 0);
873 :     V.fst true (Floatreg (z'+1)))
874 :     | float3 _ _ _ = die "float3: floating point register arguments expected"
875 :    
876 :     val fmuld = float3 V.fmul true
877 :     val fdivd = float3 V.fdiv false
878 :     val faddd = float3 V.fadd true
879 :     val fsubd = float3 V.fsub false
880 :     val fnegd = float1 V.fchs
881 :     val fabsd = float1 V.fabs
882 :    
883 :     fun cvti2d (x as Direct _, y as Floatreg y') =
884 :     (V.movl (x, tempmem);
885 :     V.fild tempmem;
886 :     V.fst true (Floatreg (y'+1)))
887 :     | cvti2d (x as Displace _, y as Floatreg y') =
888 :     (V.fild x;
889 :     V.fst true (Floatreg (y'+1)))
890 :     | cvti2d _ = die "cvti2d: bad args"
891 :    
892 :     fun fbranchd (cond, x, y, label) = let
893 :     fun fcom (x as Floatreg x', y as Floatreg y') =
894 :     if x' = 0 then V.fucom false (x, y)
895 :     else (V.fld x; V.fucom true (Floatreg 0, Floatreg (y'+1)))
896 :     | fcom _ = die "fbranchd: bad args"
897 :     fun branch () = let
898 :     fun andil i = V.andl(Immed i, tempreg)
899 :     fun xoril i = V.xorl(Immed i, tempreg)
900 :     fun cmpil i = V.cmpl(Immed i, tempreg)
901 :     in
902 :     (case cond
903 :     of P.fEQ (* = *) => (andil 0x4400; xoril 0x4000; V.jeq label)
904 :     | P.fULG (* ?<> *) => (andil 0x4400; xoril 0x4000; V.jne label)
905 :     | P.fUN (* ? *) => (V.sahf(); V.jp label)
906 :     | P.fLEG (* <=> *) => (V.sahf(); V.jnp label)
907 :     | P.fGT (* > *) => (andil 0x4500; V.jeq label)
908 :     | P.fULE (* ?<= *) => (andil 0x4500; V.jne label)
909 :     | P.fGE (* >= *) => (andil 0x500; V.jeq label)
910 :     | P.fULT (* ?< *) => (andil 0x500; V.jne label)
911 :     | P.fLT (* < *) => (andil 0x4500; cmpil 0x100; V.jeq label)
912 :     | P.fUGE (* ?>= *) => (andil 0x4500; cmpil 0x100; V.jne label)
913 :     | P.fLE (* <= *) =>
914 :     (andil 0x4100; cmpil 0x100; V.jeq label; cmpil 0x4000; V.jeq label)
915 :     | P.fUGT (* ?> *) =>
916 :     (V.sahf(); V.jp label; andil 0x4100; V.jeq label)
917 :     | P.fLG (* <> *) => (andil 0x4400; V.jeq label)
918 :     | P.fUE (* ?= *) => (andil 0x4400; V.jne label)
919 :     (*esac*))
920 :     end
921 :     in fcom (x,y); V.fnstsw(); branch()
922 :     end
923 :     end (* functor X86CM *)
924 :    
925 :    
926 :     (*
927 :     * $Log: x86.sml,v $
928 :     * Revision 1.5 1998/02/12 20:48:54 jhr
929 :     * Removed references to System.Tags.
930 :     *
931 :     * Revision 1.4 1997/12/05 06:35:14 george
932 :     * Fixed suprious overflows in subt. Fix sent in my Henry Cejtin
933 :     *
934 :     * Revision 1.3 1997/12/03 19:04:59 george
935 :     * removed rangeChk
936 :     *
937 :     * Revision 1.2 1997/05/20 12:29:53 dbm
938 :     * SML '97 sharing, where structure.
939 :     *
940 :     * Revision 1.1.1.1 1997/01/14 01:38:50 george
941 :     * Version 109.24
942 :     *
943 :     *)

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