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

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

Several changes and additions for IA-32, including mark-as-imm/mark-as-node
macros that alter bits in the TCR to indicate to the GC whether a register
contains a node or an immediate.

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