source: branches/working-0711/ccl/compiler/X86/x86-lapmacros.lisp @ 11089

Last change on this file since 11089 was 11089, checked in by gz, 13 years ago

Merge/bootstrap assorted low level stuff from trunk - kernel, syscall stuff, lowmem-bias, formatting tweaks, a few bug fixes included

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