source: trunk/source/compiler/X86/x86-lapmacros.lisp @ 10959

Last change on this file since 10959 was 10959, checked in by gb, 12 years ago

Replace uses of target::nil-value with (CCL::TARGET-NIL-VALUE) and
target::t-value with (CCL::TARGET-T-VALUE).

This was very slightly hard to bootstrap (the new backend-lowmem-bias
had to be in effect and typically 0), so I'll start checking in images
in a minute.

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