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

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

Several nargs-related changes. (nargs on x8632 is a 32-bit register; in
this branch, x8664 nargs is still a 16-bit register.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 15.9 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    `(xor (% nargs) (% nargs))
34    `(mov ($ ',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         (movl (% nargs) (% imm0))
386         (subl ($ (* $numx8632argregs x8632::node-size)) (% imm0))
387         (jle ,push)
388         (movl (% ebp) (@ 4 (% esp) (% imm0)))
389         (leal (@ 4 (% esp) (% imm0)) (% ebp))
390         (popl (@ (% ebp)))
391         (jmp ,done)
392         ,push
393         (save-simple-frame)
394         ,done))
395     (:x8664
396      `(progn
397         (movzwl (% nargs) (%l imm0))
398         (subq ($ (* $numx8664argregs x8664::node-size)) (% imm0))
399         (jle ,push)
400         (movq (% rbp) (@ 8 (% rsp) (% imm0)))
401         (leaq (@ 8 (% rsp) (% imm0)) (% rbp))
402         (popq (@ 8 (% rbp)))
403         (jmp ,done)
404         ,push
405         (save-simple-frame)
406         ,done)))))
407
408
409(defx86lapmacro restore-simple-frame ()
410  `(progn
411    (leave)))
412
413(defx86lapmacro discard-reserved-frame ()
414  (target-arch-case
415   (:x8632
416    `(add ($ '2) (% esp)))
417   (:x8664
418    `(add ($ '2) (% rsp)))))
419
420;;; Return to caller.
421(defx86lapmacro single-value-return (&optional (words-to-discard 0))
422  (target-arch-case
423   (:x8632
424    (if (zerop words-to-discard)
425        `(ret)
426        `(ret ($ ,(* x8632::node-size words-to-discard)))))
427   (:x8664
428    (if (zerop words-to-discard)
429        `(ret)
430        `(ret ($ ,(* x8664::node-size words-to-discard)))))))
431
432(defun x86-subprim-offset (name)
433  (let* ((info (find name (arch::target-subprims-table (backend-target-arch *target-backend*)) :test #'string-equal :key #'subprimitive-info-name))
434         (offset (when info 
435                   (subprimitive-info-offset info))))
436    (or offset     
437        (error "Unknown subprim: ~s" name))))
438
439(defx86lapmacro jmp-subprim (name)
440  `(jmp (@ ,(x86-subprim-offset name))))
441
442(defx86lapmacro recover-fn ()
443  `(movl ($ :self) (% fn)))
444
445(defx86lapmacro call-subprim (name)
446  (target-arch-case
447   (:x8632
448    `(progn
449       (:talign x8632::fulltag-tra)
450       (call (@ ,(x86-subprim-offset name)))
451       (recover-fn)))
452   (:x8664
453    `(progn
454       (:talign 4)
455       (call (@ ,(x86-subprim-offset name)))
456       (recover-fn-from-rip)))))
457
458 (defx86lapmacro %car (src dest)
459  (target-arch-case
460   (:x8632
461    `(movl (@ x8632::cons.car (% ,src)) (% ,dest)))
462   (:x8664
463    `(movq (@ x8664::cons.car (% ,src)) (% ,dest)))))
464
465(defx86lapmacro %cdr (src dest)
466  (target-arch-case
467   (:x8632
468    `(movl (@ x8632::cons.cdr (% ,src)) (% ,dest)))
469   (:x8664
470    `(movq (@ x8664::cons.cdr (% ,src)) (% ,dest)))))
471
472(defx86lapmacro stack-probe ()
473  (target-arch-case
474   (:x8632
475    (let* ((ok (gensym)))
476      `(progn
477         (rcmp (% esp) (@ (% rcontext) x8632::tcr.cs-limit))
478         (jae.pt ,ok)
479         (uuo-stack-overflow)
480         ,ok)))
481   (:x8664
482    (let* ((ok (gensym)))
483      `(progn
484         (rcmp (% rsp) (@ (% rcontext) x8664::tcr.cs-limit))
485         (jae.pt ,ok)
486         (uuo-stack-overflow)
487         ,ok)))))
488
489(defx86lapmacro load-constant (constant dest &optional (fn 'fn))
490  (target-arch-case
491   (:x8632
492    `(movl (@ ',constant (% ,fn)) (% ,dest)))
493   (:x8664
494    `(movq (@ ',constant (% ,fn)) (% ,dest)))))
495
496(defx86lapmacro recover-fn-from-rip ()
497  (let* ((next (gensym)))
498    `(progn
499      (lea (@ (- (:^ ,next)) (% rip)) (% fn))
500      ,next)))
501
502;;; call symbol named NAME, setting nargs to NARGS.  Do the TRA
503;;; hair.   Args should already be in arg regs, and we expect
504;;; to return a single value.
505(defx86lapmacro call-symbol (name nargs)
506  (target-arch-case
507   (:x8632
508    `(progn
509       (load-constant ,name fname)
510       (set-nargs ,nargs)
511       (:talign 5)
512       (call (@ x8632::symbol.fcell (% fname)))
513       (recover-fn)))
514   (:x8664
515    `(progn
516       (load-constant ,name fname)
517       (set-nargs ,nargs)
518       (:talign 4)
519       (call (@ x8664::symbol.fcell (% fname)))
520       (recover-fn-from-rip)))))
521
522
523;;;  tail call the function named by NAME with nargs NARGS.  %FN is
524;;;  the caller, which will be in %FN on entry to the callee.  For the
525;;;  couple of instructions where neither %RA0 or %FN point to the
526;;;  current function, ensure that %XFN does; this is necessary to
527;;;  prevent the current function from being GCed halfway through
528;;;  those couple of instructions.
529
530(defx86lapmacro jump-symbol (name nargs)
531  (target-arch-case
532   (:x8632
533    `(progn
534       (load-constant ,name fname)
535       (set-nargs ,nargs)
536       (jmp (@ x8632::symbol.fcell (% fname)))))
537   (:x8664
538    `(progn
539       (load-constant ,name fname)
540       (set-nargs ,nargs)
541       (jmp (@ x8664::symbol.fcell (% fname)))))))
542
543(defx86lapmacro push-argregs ()
544  (let* ((done (gensym))
545         (yz (gensym))
546         (z (gensym)))
547    (target-arch-case
548     (:x8632
549      `(progn
550         (testl (% nargs) (% nargs))
551         (je ,done)
552         (cmpl ($ '1) (% nargs))
553         (je ,z)
554         (push (% arg_y))
555         ,z
556         (push (% arg_z))
557         ,done))
558     (:x8664
559      `(progn
560         (testw (% nargs) (% nargs))
561         (je ,done)
562         (cmpw ($ '2) (% nargs))
563         (je ,yz)
564         (jb ,z)
565         (push (% arg_x))
566         ,yz
567         (push (% arg_y))
568         ,z
569         (push (% arg_z))
570         ,done)))))
571
572;;; clears reg
573(defx86lapmacro mark-as-node (reg)
574  (let* ((regnum (logand #x7 (x86::gpr-ordinal (string reg))))
575         (bit (ash 1 regnum)))
576    `(progn
577       (xorl (% ,reg) (% ,reg))
578       (orb ($ ,bit) (@ (% :rcontext) x8632::tcr.node-regs-mask)))))
579
580(defx86lapmacro mark-as-imm (reg)
581  (let* ((regnum (logand #x7 (x86::gpr-ordinal (string reg))))
582         (bit (ash 1 regnum)))
583    `(progn
584       (andb ($ (lognot ,bit)) (@ (% :rcontext) x8632::tcr.node-regs-mask)))))
585
Note: See TracBrowser for help on using the repository browser.