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

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

propagate changes from working-0711-perf branch

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