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

Last change on this file since 8368 was 8368, checked in by rme, 12 years ago

Treat nargs as a 32-bit register.

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