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

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

Treat nargs as having at least 32 significant bits.
Avoid partial register writes in a few cases.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.1 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 clrq (reg)
26  `(xorq (% ,reg) (% ,reg)))
27
28(defx86lapmacro set-nargs (n)
29  (if (eql n 0)
30    `(xorl (%l nargs) (%l nargs))
31    `(movl ($ ',n) (%l nargs))))
32
33(defx86lapmacro anchored-uuo (form)
34  `(progn
35    ,form
36    (:byte 0)))
37
38(defx86lapmacro check-nargs (min &optional (max min))
39  (let* ((anchor (gensym))
40         (bad (gensym)))
41    (if (and max (= max min))
42      `(progn
43        ,anchor
44        ,(if (eql min 0)
45             `(testl (% nargs) (% nargs))
46             `(rcmp (% nargs) ($ ',min)))
47        (jne ,bad)
48        (:anchored-uuo-section ,anchor)
49        ,bad
50        (anchored-uuo (uuo-error-wrong-number-of-args))
51        (:main-section nil))
52      (if (null max)
53        (unless (zerop min)
54          `(progn
55            ,anchor
56            (rcmp (% nargs) ($ ',min))
57            (jb ,bad)
58            (:anchored-uuo-section ,anchor)
59            ,bad
60            (anchored-uuo (uuo-error-too-few-args))
61            (:main-section nil)))
62        (if (zerop min)
63          `(progn
64            ,anchor
65            (rcmp (% nargs) ($ ',max))
66            (ja ,bad)
67            (:anchored-uuo-section ,anchor)
68            ,bad
69            (anchored-uuo (uuo-error-too-many-args))
70            (:main-section nil))
71          (let* ((toofew (gensym))
72                 (toomany (gensym)))
73            `(progn
74              ,anchor
75              (rcmp (% nargs) ($ ',min))
76              (jb ,toofew)
77              (rcmp (% nargs) ($ ',max))
78              (ja ,toomany)
79              (:anchored-uuo-section ,anchor)
80              ,toofew
81              (anchored-uuo (uuo-error-too-few-args))
82              (:anchored-uuo-section ,anchor)
83              ,toomany
84              (anchored-uuo (uuo-error-too-many-args)))))))))
85
86
87
88(defx86lapmacro extract-lisptag (node dest)
89  `(progn
90    (movl (%l ,node) (%l ,dest))
91    (andl ($ x8664::tagmask) (%l ,dest))))
92
93(defx86lapmacro extract-fulltag (node dest)
94  `(progn
95    (movl (%l ,node) (%l ,dest))
96    (andl ($ x8664::fulltagmask) (%l ,dest))))
97
98(defx86lapmacro extract-subtag (node dest)
99  `(movb (@ x8664::misc-subtag-offset (% ,node)) (%b ,dest)))
100
101(defx86lapmacro extract-typecode (node dest)
102  (let* ((done (gensym)))
103    `(progn
104      (extract-lisptag ,node ,dest)
105      (rcmp (%b ,dest) ($ x8664::tag-misc))
106      (jne ,done)
107      (movzbl (@  x8664::misc-subtag-offset (% ,node)) (%l ,dest))
108      ,done)))
109
110(defx86lapmacro trap-unless-typecode= (node tag &optional (immreg 'imm0))
111  (let* ((bad (gensym))
112         (anchor (gensym)))
113    `(progn
114      ,anchor
115      (extract-typecode ,node ,immreg)
116      (cmpb ($ ,tag) (%b ,immreg))
117      (jne ,bad)
118      (:anchored-uuo-section ,anchor)
119      ,bad
120      (anchored-uuo (uuo-error-reg-not-tag (% ,node) ($ ,tag)))
121      (:main-section nil))))
122
123(defx86lapmacro trap-unless-fulltag= (node tag &optional (immreg 'imm0))
124  (let* ((bad (gensym))
125         (anchor (gensym)))
126    `(progn
127      ,anchor
128      (extract-fulltag ,node ,immreg)
129      (cmpb ($ ,tag) (%b ,immreg))
130      (jne ,bad)
131      (:anchored-uuo-section ,anchor)
132      ,bad
133      (anchored-uuo (uuo-error-reg-not-tag (% ,node) ($ ,tag)))
134      (:main-section nil))))
135
136(defx86lapmacro trap-unless-lisptag= (node tag &optional (immreg 'imm0))
137  (let* ((bad (gensym))
138         (anchor (gensym)))
139    `(progn
140      ,anchor
141      (extract-lisptag ,node ,immreg)
142      (cmpb ($ ,tag) (%b ,immreg))
143      (jne ,bad)
144      (:anchored-uuo-section ,anchor)
145      ,bad
146      (anchored-uuo (uuo-error-reg-not-tag (% ,node) ($ ,tag)))
147      (:main-section nil))))
148
149(defx86lapmacro trap-unless-fixnum (node)
150  (let* ((bad (gensym))
151         (anchor (gensym)))
152    `(progn
153      ,anchor
154      (testb ($ x8664::tagmask) (%b ,node))
155      (jne ,bad)
156      (:anchored-uuo-section ,anchor)
157      ,bad
158      (anchored-uuo (uuo-error-reg-not-fixnum (% ,node)))
159      (:main-section nil))))
160
161;;; On x8664, NIL has its own tag, so no other lisp object can
162;;; have the same low byte as NIL.  (That probably won't be
163;;; true on x8632.)
164(defx86lapmacro cmp-reg-to-nil (reg)
165  `(cmpb ($ (logand #xff x8664::nil-value)) (%b ,reg)))
166
167
168(defx86lapmacro unbox-fixnum (src dest)
169  `(progn
170    (mov (% ,src) (% ,dest))
171    (sar ($ x8664::fixnumshift) (% ,dest))))
172
173(defx86lapmacro box-fixnum (src dest)
174  `(imulq ($ x8664::fixnumone) (% ,src) (% ,dest)))
175
176
177(defx86lapmacro get-single-float (node dest)
178  `(progn
179    (movd (% ,node) (% ,dest))
180    (psrlq ($ 32) (% ,dest))))
181
182
183;;; Note that this modifies the src argument.
184(defx86lapmacro put-single-float (src node)
185  `(progn
186    (psllq ($ 32) (% ,src))
187    (movd (% ,src) (% ,node))
188    (movb ($ x8664::tag-single-float) (%b ,node))))
189
190(defx86lapmacro get-double-float (src fpreg)
191  `(movsd (@ x8664::double-float.value (% ,src)) (% ,fpreg)))
192
193(defx86lapmacro put-double-float (fpreg dest)
194  `(movsd (% ,fpreg) (@ x8664::double-float.value (% ,dest))))
195 
196
197 
198(defx86lapmacro getvheader (src dest)
199  `(movq (@ x8664::misc-header-offset (% ,src)) (% ,dest)))
200
201;;; "Size" is unboxed element-count.  vheader and dest should
202;;; both be immediate registers
203(defx86lapmacro header-size (vheader dest)
204  `(progn
205    (mov (% ,vheader) (% ,dest))
206    (shr ($ x8664::num-subtag-bits) (% ,dest))))
207
208
209;;; "Length" is fixnum element-count.
210(defx86lapmacro header-length (vheader dest)
211  `(progn
212    (movq ($ (lognot 255)) (% ,dest))
213    (andq (% ,vheader) (% ,dest))
214    (shr ($ (- x8664::num-subtag-bits x8664::fixnumshift)) (% ,dest))))
215
216(defx86lapmacro header-subtag[fixnum] (vheader dest)
217  `(progn
218    (lea (@ (% ,vheader) 8) (% ,dest))
219    (andl ($ '255) (%l ,dest))))
220
221(defx86lapmacro vector-size (vector vheader dest)
222  `(progn
223    (getvheader ,vector ,vheader)
224    (header-size ,vheader ,dest)))
225
226(defx86lapmacro vector-length (vector dest)
227  `(progn
228    (movq ($ (lognot 255)) (% ,dest))
229    (andq (@ x8664::misc-header-offset (% ,vector)) (% ,dest))
230    (shr ($ (- x8664::num-subtag-bits x8664::fixnumshift)) (% ,dest)))) 
231
232
233(defx86lapmacro int-to-double (int temp double)
234  `(progn
235    (unbox-fixnum  ,int ,temp)
236    (cvtsi2sdq (% ,temp) (% ,double))))
237
238(defx86lapmacro int-to-single (int temp single)
239  `(progn
240    (unbox-fixnum ,int ,temp)
241    (cvtsi2ssq (% ,temp) (% ,single))))
242
243(defx86lapmacro ref-global (global reg)
244  `(movq (@ (+ x8664::nil-value ,(x8664::%kernel-global global))) (% ,reg)))
245
246(defx86lapmacro ref-global.l (global reg)
247  `(movl (@ (+ x8664::nil-value ,(x8664::%kernel-global global))) (%l ,reg)))
248
249(defx86lapmacro set-global (reg global)
250  `(movq (% ,reg) (@ (+ x8664::nil-value ,(x8664::%kernel-global global)))))
251
252(defx86lapmacro macptr-ptr (src dest)
253  `(movq (@ x8664::macptr.address (% ,src)) (% ,dest)))
254
255;;; CODE is unboxed char-code (in low 8 bits); CHAR needs to be boxed.
256(defx86lapmacro box-character (code char)
257  `(progn
258    (box-fixnum ,code ,char)
259    (shl ($ (- x8664::charcode-shift x8664::fixnumshift)) (% ,char))
260    (movb ($ x8664::subtag-character) (%b ,char))))
261
262 
263;;; index is a constant
264(defx86lapmacro svref (vector index dest)
265  `(movq (@ (+ x8664::misc-data-offset (* ,index 8)) (% ,vector)) (% ,dest)))
266
267;;; Index is still a constant
268(defx86lapmacro svset (vector index new)
269  `(movq (% ,new) (@ (+ x8664::misc-data-offset (* ,index 8)) (% ,vector))))
270
271
272
273;;; Frames, function entry and exit.
274
275
276;;; Simple frame, since the caller didn't reserve space for it.
277(defx86lapmacro save-simple-frame ()
278  `(progn
279    (pushq (% rbp))
280    (movq (% rsp) (% rbp))))
281
282(defx86lapmacro save-frame-variable-arg-count ()
283  (let* ((push (gensym))
284         (done (gensym)))
285  `(progn
286    (movzwl (%w nargs) (%l imm0))
287    (subq ($ (* $numx8664argregs x8664::node-size)) (% imm0))
288    (jle ,push)
289    (movq (% rbp) (@ 8 (% rsp) (% imm0)))
290    (leaq (@ 8 (% rsp) (% imm0)) (% rbp))
291    (popq (@ 8 (% rbp)))
292    (jmp ,done)
293    ,push
294    (save-simple-frame)
295    ,done)))
296
297
298(defx86lapmacro restore-simple-frame ()
299  `(progn
300    (leave)))
301
302
303
304(defx86lapmacro discard-reserved-frame ()
305  `(add ($ '2) (% rsp)))
306
307;;; Return to caller.
308(defx86lapmacro single-value-return (&optional (words-to-discard 0))
309  (if (zerop words-to-discard)
310    `(ret)
311    `(ret ($ ,(* x8664::node-size words-to-discard)))))
312
313;;; Using *x8664-backend* here is wrong but expedient.
314(defun x86-subprim-offset (name)
315  (let* ((info (find name (arch::target-subprims-table (backend-target-arch *x8664-backend*)) :test #'string-equal :key #'subprimitive-info-name))
316         (offset (when info 
317                   (subprimitive-info-offset info))))
318    (or offset     
319      (error "Unknown subprim: ~s" name))))
320
321(defx86lapmacro jmp-subprim (name)
322  `(jmp (@ ,(x86-subprim-offset name))))
323
324(defx86lapmacro call-subprim (name)
325  `(progn
326    (:talign 4)
327    (call (@ ,(x86-subprim-offset name)))
328    (recover-fn-from-rip)))
329
330     
331(defx86lapmacro %car (src dest)
332  `(movq (@ x8664::cons.car (% ,src)) (% ,dest)))
333
334(defx86lapmacro %cdr (src dest)
335  `(movq (@ x8664::cons.cdr (% ,src)) (% ,dest)))
336
337(defx86lapmacro stack-probe ()
338  (let* ((ok (gensym)))
339    `(progn
340      (rcmp (% rsp) (@ (% rcontext) x8664::tcr.cs-limit))
341      (jae.pt ,ok)
342      (uuo-stack-overflow)
343      ,ok)))
344
345(defx86lapmacro load-constant (constant dest &optional (fn 'fn))
346  `(movq (@ ',constant (% ,fn)) (% ,dest)))
347
348(defx86lapmacro recover-fn-from-rip ()
349  (let* ((next (gensym)))
350    `(progn
351      (lea (@ (- (:^ ,next)) (% rip)) (% fn))
352      ,next)))
353
354;;; call symbol named NAME, setting nargs to NARGS.  Do the TRA
355;;; hair.   Args should already be in arg regs, and we expect
356;;; to return a single value.
357(defx86lapmacro call-symbol (name nargs)
358  `(progn
359    (load-constant ,name fname)
360    (set-nargs ,nargs)
361    (:talign 4)
362    (call (@ x8664::symbol.fcell (% fname)))
363    (recover-fn-from-rip)))
364
365
366;;;  tail call the function named by NAME with nargs NARGS.  %FN is
367;;;  the caller, which will be in %FN on entry to the callee.  For the
368;;;  couple of instructions where neither %RA0 or %FN point to the
369;;;  current function, ensure that %XFN does; this is necessary to
370;;;  prevent the current function from being GCed halfway through
371;;;  those couple of instructions.
372(defx86lapmacro jump-symbol (name nargs)
373  `(progn
374    (load-constant ,name fname)
375    (set-nargs ,nargs)
376    (jmp (@ x8664::symbol.fcell (% fname)))))
377
378(defx86lapmacro push-argregs ()
379  (let* ((done (gensym))
380         (yz (gensym))
381         (z (gensym)))
382  `(progn
383    (testl (% nargs) (% nargs))
384    (je ,done)
385    (cmpl ($ '2) (% nargs))
386    (je ,yz)
387    (jb ,z)
388    (push (% arg_x))
389    ,yz
390    (push (% arg_y))
391    ,z
392    (push (% arg_z))
393    ,done)))
394   
Note: See TracBrowser for help on using the repository browser.