source: branches/ia32/compiler/X86/x86-lapmacros.lisp @ 7242

Last change on this file since 7242 was 7242, checked in by rme, 13 years ago

Use x86-byte-reg-p and x86-acc-reg-p in a couple places.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 15.3 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2005, Clozure Associates and contributors.
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19;;; Comparisons make more sense if arg order is "dest, src", instead
20;;; of the gas/ATT arg order.
21
22(defx86lapmacro rcmp (src dest)
23  `(cmp ,dest ,src))
24
25(defx86lapmacro clrl (reg)
26  `(xorl (% ,reg) (% ,reg)))
27
28(defx86lapmacro clrq (reg)
29  `(xorq (% ,reg) (% ,reg)))
30
31(defx86lapmacro set-nargs (n)
32  (if (eql n 0)
33    `(xorw (% nargs) (% nargs))
34    `(movw ($ ',n) (% nargs))))
35
36(defx86lapmacro check-nargs (min &optional (max min))
37  (let* ((ok (gensym)))
38    (if (and max (= max min))
39      `(progn
40        (rcmp (% nargs) ($ ',min))
41        (je.pt ,ok)
42        (uuo-error-wrong-number-of-args)
43        ,ok)
44      (if (null max)
45        (unless (zerop min)
46          `(progn
47            (rcmp (% nargs) ($ ',min))
48            (jae.pt  ,ok)
49            (uuo-error-too-few-args)
50            ,ok))
51        (if (zerop min)
52          `(progn
53            (rcmp (% nargs) ($ ',max))
54            (jb.pt  ,ok)
55            (uuo-error-too-many-args)
56            ,ok)
57          (let* ((sofar (gensym)))
58            `(progn
59              (rcmp (% nargs) ($ ',min))
60              (jae.pt  ,sofar)
61              (uuo-error-too-few-args)
62              ,sofar
63              (rcmp (% nargs) ($ ',max))
64              (jbe.pt  ,ok)
65              (uuo-error-too-many-args)
66              ,ok)))))))
67
68
69(defx86lapmacro extract-lisptag (node dest)
70  (target-arch-case
71   (:x8632
72    (assert (x86-acc-reg-p dest) () "dest reg must be accumulator")
73    `(progn
74       (movb ($ x8632::tagmask) (%b ,dest))
75       (andl (%l ,node) (%l ,dest))))
76   (:x8664
77    `(progn
78       (movb ($ x8664::tagmask) (%b ,dest))
79       (andb (%b ,node) (%b ,dest))))))
80
81(defx86lapmacro extract-fulltag (node dest)
82  (target-arch-case
83   (:x8632
84    (if (and (x86-byte-reg-p node) (x86-byte-reg-p dest))
85      `(progn (movb ($ x8632::fulltagmask) (%b ,dest))
86              (andb (%b ,node) (%b ,dest)))
87      `(progn (movl ($ x8632::fulltagmask) (%l ,dest))
88              (andl (%l ,node) (%l ,dest)))))
89   (:x8664
90    `(progn
91       (movb ($ x8664::fulltagmask) (%b ,dest))
92       (andb (%b ,node) (%b ,dest))))))
93
94(defx86lapmacro extract-subtag (node dest)
95  (target-arch-case
96   (:x8632
97    `(movb (@ x8632::misc-subtag-offset (% ,node)) (%b ,dest)))
98   (:x8664
99    `(movb (@ x8664::misc-subtag-offset (% ,node)) (%b ,dest)))))
100
101(defx86lapmacro extract-typecode (node dest)
102  ;;; In general, these things are only defined to affect the low
103  ;;; byte of the destination register.  This can also affect
104  ;;; the #xff00 byte.
105  (let* ((done (gensym)))
106    (target-arch-case
107     (:x8632
108      `(progn
109         (extract-lisptag ,node ,dest)
110         (rcmp (%b ,dest) ($ x8632::tag-misc))
111         (jne ,done)
112         (movb (@  x8632::misc-subtag-offset (% ,node)) (%b ,dest))
113         ,done))
114     (:x8664
115      `(progn
116         (extract-lisptag ,node ,dest)
117         (rcmp (%b ,dest) ($ x8664::tag-misc))
118         (jne ,done)
119         (movb (@  x8664::misc-subtag-offset (% ,node)) (%b ,dest))
120         ,done)))))
121
122(defx86lapmacro trap-unless-typecode= (node tag &optional (immreg 'imm0))
123  (let* ((ok (gensym)))
124    `(progn
125      (extract-typecode ,node ,immreg)
126      (cmpb ($ ,tag) (%b ,immreg))
127      (je.pt ,ok)
128      (uuo-error-reg-not-tag (% ,node) ($ ,tag))
129      ,ok)))
130
131(defx86lapmacro trap-unless-fulltag= (node tag &optional (immreg 'imm0))
132  (let* ((ok (gensym)))
133    `(progn
134      (extract-fulltag ,node ,immreg)
135      (cmpb ($ ,tag) (%b ,immreg))
136      (je.pt ,ok)
137      (uuo-error-reg-not-tag (% ,node) ($ ,tag))
138      ,ok)))
139
140(defx86lapmacro trap-unless-lisptag= (node tag &optional (immreg 'imm0))
141  (let* ((ok (gensym)))
142    `(progn
143      (extract-lisptag ,node ,immreg)
144      (cmpb ($ ,tag) (%b ,immreg))
145      (je.pt ,ok)
146      (uuo-error-reg-not-tag (% ,node) ($ ,tag))
147      ,ok)))
148
149(defx86lapmacro trap-unless-fixnum (node)
150  (let* ((ok (gensym)))
151    (target-arch-case
152     (:x8632
153      `(progn
154         (testb ($ x8632::tagmask) (%b ,node))
155         (je.pt ,ok)
156         (uuo-error-reg-not-fixnum (% ,node))
157         ,ok))
158     (:x8664
159      `(progn
160         (testb ($ x8664::tagmask) (%b ,node))
161         (je.pt ,ok)
162         (uuo-error-reg-not-fixnum (% ,node))
163         ,ok)))))
164
165;;; On x8664, NIL has its own tag, so no other lisp object can
166;;; have the same low byte as NIL.  On x8632, NIL is a just
167;;; a distiguished CONS.
168(defx86lapmacro cmp-reg-to-nil (reg)
169  (target-arch-case
170   (:x8632
171    `(cmpl ($ x8632::nil-value) (%l ,reg)))
172   (:x8664
173    `(cmpb ($ (logand #xff x8664::nil-value)) (%b ,reg)))))
174
175(defx86lapmacro unbox-fixnum (src dest)
176  (target-arch-case
177   (:x8632
178    `(progn
179       (mov (% ,src) (% ,dest))
180       (sar ($ x8632::fixnumshift) (% ,dest))))
181   (:x8664
182    `(progn
183       (mov (% ,src) (% ,dest))
184       (sar ($ x8664::fixnumshift) (% ,dest))))))
185
186(defx86lapmacro box-fixnum (src dest)
187  (target-arch-case
188   (:x8632
189    `(imull ($ x8632::fixnumone) (% ,src) (% ,dest)))
190   (:x8664
191    `(imulq ($ x8664::fixnumone) (% ,src) (% ,dest)))))
192
193(defx86lapmacro get-single-float (node dest)
194  `(progn
195    (movd (% ,node) (% ,dest))
196    (psrlq ($ 32) (% ,dest))))
197
198
199;;; Note that this modifies the src argument.
200(defx86lapmacro put-single-float (src node)
201  `(progn
202    (psllq ($ 32) (% ,src))
203    (movd (% ,src) (% ,node))
204    (movb ($ x8664::tag-single-float) (%b ,node))))
205
206(defx86lapmacro get-double-float (src fpreg)
207  (target-arch-case
208   (:x8632
209    `(movsd (@ x8632::double-float.value (% ,src)) (% ,fpreg)))
210   (:x8664
211    `(movsd (@ x8664::double-float.value (% ,src)) (% ,fpreg)))))
212
213(defx86lapmacro put-double-float (fpreg dest)
214  (target-arch-case
215   (:x8632
216    `(movsd (% ,fpreg) (@ x8632::double-float.value (% ,dest))))
217   (:x8664
218    `(movsd (% ,fpreg) (@ x8664::double-float.value (% ,dest))))))
219 
220(defx86lapmacro getvheader (src dest)
221  (target-arch-case
222   (:x8632
223    `(movl (@ x8632::misc-header-offset (% ,src)) (% ,dest)))
224   (:x8664
225    `(movq (@ x8664::misc-header-offset (% ,src)) (% ,dest)))))
226
227;;; "Size" is unboxed element-count.  vheader and dest should
228;;; both be immediate registers
229(defx86lapmacro header-size (vheader dest)
230  (target-arch-case
231   (:x8632
232    `(progn
233       (mov (% ,vheader) (% ,dest))
234       (shr ($ x8632::num-subtag-bits) (% ,dest))))
235   (:x8664
236    `(progn
237       (mov (% ,vheader) (% ,dest))
238       (shr ($ x8664::num-subtag-bits) (% ,dest))))))
239
240;;; "Length" is fixnum element-count.
241(defx86lapmacro header-length (vheader dest)
242  (target-arch-case
243   (:x8632
244    `(progn
245       (movl ($ (lognot 255)) (% ,dest))
246       (andl (% ,vheader) (% ,dest))
247       (shr ($ (- x8632::num-subtag-bits x8632::fixnumshift)) (% ,dest))))
248   (:x8664
249    `(progn
250       (movq ($ (lognot 255)) (% ,dest))
251       (andq (% ,vheader) (% ,dest))
252       (shr ($ (- x8664::num-subtag-bits x8664::fixnumshift)) (% ,dest))))))
253
254(defx86lapmacro header-subtag[fixnum] (vheader dest)
255  `(progn
256    (lea (@ (% ,vheader) 8) (% ,dest))
257    (andl ($ '255) (%l ,dest))))
258
259(defx86lapmacro vector-size (vector vheader dest)
260  `(progn
261    (getvheader ,vector ,vheader)
262    (header-size ,vheader ,dest)))
263
264(defx86lapmacro vector-length (vector dest)
265  (target-arch-case
266   (:x8632
267    `(progn
268       (movq ($ (lognot 255)) (% ,dest))
269       (andq (@ x8632::misc-header-offset (% ,vector)) (% ,dest))
270       (shr ($ (- x8632::num-subtag-bits x8632::fixnumshift)) (% ,dest))))
271   (:x8664
272    `(progn
273       (movq ($ (lognot 255)) (% ,dest))
274       (andq (@ x8664::misc-header-offset (% ,vector)) (% ,dest))
275       (shr ($ (- x8664::num-subtag-bits x8664::fixnumshift)) (% ,dest))))))
276
277(defx86lapmacro int-to-double (int temp double)
278  `(progn
279    (unbox-fixnum  ,int ,temp)
280    (cvtsi2sdq (% ,temp) (% ,double))))
281
282(defx86lapmacro int-to-single (int temp single)
283  `(progn
284    (unbox-fixnum ,int ,temp)
285    (cvtsi2ssq (% ,temp) (% ,single))))
286
287(defx86lapmacro ref-global (global reg)
288  (target-arch-case
289   (:x8632
290    `(movl (@ (+ x8632::nil-value ,(x8632::%kernel-global global))) (% ,reg)))
291   (:x8664
292    `(movq (@ (+ x8664::nil-value ,(x8664::%kernel-global global))) (% ,reg)))))
293
294(defx86lapmacro ref-global.l (global reg)
295  (target-arch-case
296   (:x8632
297    `(movl (@ (+ x8632::nil-value ,(x8632::%kernel-global global))) (%l ,reg)))
298   (:x8664
299    `(movl (@ (+ x8664::nil-value ,(x8664::%kernel-global global))) (%l ,reg)))))
300
301(defx86lapmacro set-global (reg global)
302  (target-arch-case
303   (:x8632
304    `(movl (% ,reg) (@ (+ x8632::nil-value ,(x8632::%kernel-global global)))))
305   (:x8664
306    `(movq (% ,reg) (@ (+ x8664::nil-value ,(x8664::%kernel-global global)))))))
307
308(defx86lapmacro macptr-ptr (src dest)
309  (target-arch-case
310   (:x8632
311    `(movl (@ x8632::macptr.address (% ,src)) (% ,dest)))
312   (:x8664
313    `(movq (@ x8664::macptr.address (% ,src)) (% ,dest)))))
314
315;;; CODE is unboxed char-code (in low 8 bits); CHAR needs to be boxed.
316(defx86lapmacro box-character (code char)
317  (target-arch-case
318   (:x8632
319    `(progn
320       (box-fixnum ,code ,char)
321       (shl ($ (- x8632::charcode-shift x8632::fixnumshift)) (% ,char))
322       (movb ($ x8632::subtag-character) (%b ,char))))
323   (:x8664
324    `(progn
325       (box-fixnum ,code ,char)
326       (shl ($ (- x8664::charcode-shift x8664::fixnumshift)) (% ,char))
327       (movb ($ x8664::subtag-character) (%b ,char))))))
328 
329;;; index is a constant
330(defx86lapmacro svref (vector index dest)
331  (target-arch-case
332   (:x8632
333    `(movl (@ (+ x8632::misc-data-offset (* ,index 4)) (% ,vector)) (% ,dest)))
334   (:x8664
335    `(movq (@ (+ x8664::misc-data-offset (* ,index 8)) (% ,vector)) (% ,dest)))))
336
337;;; Index is still a constant
338(defx86lapmacro svset (vector index new)
339  (target-arch-case
340   (:x8632
341    `(movl (% ,new) (@ (+ x8632::misc-data-offset (* ,index 4)) (% ,vector))))
342   (:x8664
343    `(movq (% ,new) (@ (+ x8664::misc-data-offset (* ,index 8)) (% ,vector))))))
344
345
346;;; Frames, function entry and exit.
347
348
349;;; Simple frame, since the caller didn't reserve space for it.
350(defx86lapmacro save-simple-frame ()
351  (target-arch-case
352   (:x8632
353    `(progn
354       (pushl (% ebp))
355       (movl (% esp) (% ebp))))
356   (:x8664
357    `(progn
358       (pushq (% rbp))
359       (movq (% rsp) (% rbp))))))
360
361;;; need better understanding than just a vague notion
362;;; of what is going on here
363(defx86lapmacro save-frame-variable-arg-count ()
364  (let* ((push (gensym))
365         (done (gensym)))
366    (target-arch-case
367     (:x8632
368      `(progn
369         (movzxwl (% nargs) (% imm0))
370         (subl ($ (* $numx8632argregs x8632::node-size)) (% imm0))
371         (jle ,push)
372         (movl (% ebp) (@ 4 (% esp) (% imm0)))
373         (leaq (@ 4 (% esp) (% imm0)) (% ebp))
374         (popl (@ (% ebp)))
375         (jmp ,done)
376         ,push
377         (save-simple-frame)
378         ,done))
379     (:x8664
380      `(progn
381         (movzwl (% nargs) (%l imm0))
382         (subq ($ (* $numx8664argregs x8664::node-size)) (% imm0))
383         (jle ,push)
384         (movq (% rbp) (@ 8 (% rsp) (% imm0)))
385         (leaq (@ 8 (% rsp) (% imm0)) (% rbp))
386         (popq (@ 8 (% rbp)))
387         (jmp ,done)
388         ,push
389         (save-simple-frame)
390         ,done)))))
391
392
393(defx86lapmacro restore-simple-frame ()
394  `(progn
395    (leave)))
396
397(defx86lapmacro discard-reserved-frame ()
398  (target-arch-case
399   (:x8632
400    `(add ($ '2) (% esp)))
401   (:x8664
402    `(add ($ '2) (% rsp)))))
403
404;;; Return to caller.
405(defx86lapmacro single-value-return (&optional (words-to-discard 0))
406  (target-arch-case
407   (:x8632
408    (if (zerop words-to-discard)
409        `(ret)
410        `(ret ($ ,(* x8632::node-size words-to-discard)))))
411   (:x8664
412    (if (zerop words-to-discard)
413        `(ret)
414        `(ret ($ ,(* x8664::node-size words-to-discard)))))))
415
416(defun x86-subprim-offset (name)
417  (let* ((info (find name (arch::target-subprims-table (backend-target-arch *target-backend*)) :test #'string-equal :key #'subprimitive-info-name))
418         (offset (when info 
419                   (subprimitive-info-offset info))))
420    (or offset     
421        (error "Unknown subprim: ~s" name))))
422
423(defx86lapmacro jmp-subprim (name)
424  `(jmp (@ ,(x86-subprim-offset name))))
425
426(defx86lapmacro recover-fn ()
427  `(movl ($ :self) (% fn)))
428
429(defx86lapmacro call-subprim (name)
430  (target-arch-case
431   (:x8632
432    `(progn
433       (:talign x8632::fulltag-tra)
434       (call (@ ,(x86-subprim-offset name)))
435       (recover-fn)))
436   (:x8664
437    `(progn
438       (:talign 4)
439       (call (@ ,(x86-subprim-offset name)))
440       (recover-fn-from-rip)))))
441
442 (defx86lapmacro %car (src dest)
443  (target-arch-case
444   (:x8632
445    `(movl (@ x8632::cons.car (% ,src)) (% ,dest)))
446   (:x8664
447    `(movq (@ x8664::cons.car (% ,src)) (% ,dest)))))
448
449(defx86lapmacro %cdr (src dest)
450  (target-arch-case
451   (:x8632
452    `(movl (@ x8632::cons.cdr (% ,src)) (% ,dest)))
453   (:x8664
454    `(movq (@ x8664::cons.cdr (% ,src)) (% ,dest)))))
455
456(defx86lapmacro stack-probe ()
457  (target-arch-case
458   (:x8632
459    (let* ((ok (gensym)))
460      `(progn
461         (rcmp (% esp) (@ (% rcontext) x8632::tcr.cs-limit))
462         (jae.pt ,ok)
463         (uuo-stack-overflow)
464         ,ok)))
465   (:x8664
466    (let* ((ok (gensym)))
467      `(progn
468         (rcmp (% rsp) (@ (% rcontext) x8664::tcr.cs-limit))
469         (jae.pt ,ok)
470         (uuo-stack-overflow)
471         ,ok)))))
472
473(defx86lapmacro load-constant (constant dest &optional (fn 'fn))
474  (target-arch-case
475   (:x8632
476    `(movl (@ ',constant (% ,fn)) (% ,dest)))
477   (:x8664
478    `(movq (@ ',constant (% ,fn)) (% ,dest)))))
479
480(defx86lapmacro recover-fn-from-rip ()
481  (let* ((next (gensym)))
482    `(progn
483      (lea (@ (- (:^ ,next)) (% rip)) (% fn))
484      ,next)))
485
486;;; call symbol named NAME, setting nargs to NARGS.  Do the TRA
487;;; hair.   Args should already be in arg regs, and we expect
488;;; to return a single value.
489(defx86lapmacro call-symbol (name nargs)
490  (target-arch-case
491   (:x8632
492    `(progn
493       (load-constant ,name fname)
494       (set-nargs ,nargs)
495       (:talign 5)
496       (call (@ x8632::symbol.fcell (% fname)))
497       (recover-fn)))
498   (:x8664
499    `(progn
500       (load-constant ,name fname)
501       (set-nargs ,nargs)
502       (:talign 4)
503       (call (@ x8664::symbol.fcell (% fname)))
504       (recover-fn-from-rip)))))
505
506
507;;;  tail call the function named by NAME with nargs NARGS.  %FN is
508;;;  the caller, which will be in %FN on entry to the callee.  For the
509;;;  couple of instructions where neither %RA0 or %FN point to the
510;;;  current function, ensure that %XFN does; this is necessary to
511;;;  prevent the current function from being GCed halfway through
512;;;  those couple of instructions.
513
514;;; The above comment appears to be stale.
515;;; %fn (which is distinct from %fname) will be pointing to
516;;; the current function, so it won't get GCed out from under us.
517(defx86lapmacro jump-symbol (name nargs)
518  (target-arch-case
519   (:x8632
520    `(progn
521       (load-constant ,name fname)
522       (set-nargs ,nargs)
523       (jmp (@ x8632::symbol.fcell (% fname)))))
524   (:x8664
525    `(progn
526       (load-constant ,name fname)
527       (set-nargs ,nargs)
528       (jmp (@ x8664::symbol.fcell (% fname)))))))
529
530(defx86lapmacro push-argregs ()
531  (let* ((done (gensym))
532         (yz (gensym))
533         (z (gensym)))
534    (target-arch-case
535     (:x8632
536      `(progn
537         (testw (% nargs) (% nargs))
538         (je ,done)
539         (cmpw ($ '1) (% nargs))
540         (je ,z)
541         (push (% arg_y))
542         ,z
543         (push (% arg_z))
544         ,done))
545     (:x8664
546      `(progn
547         (testw (% nargs) (% nargs))
548         (je ,done)
549         (cmpw ($ '2) (% nargs))
550         (je ,yz)
551         (jb ,z)
552         (push (% arg_x))
553         ,yz
554         (push (% arg_y))
555         ,z
556         (push (% arg_z))
557         ,done)))))
558   
Note: See TracBrowser for help on using the repository browser.