source: trunk/source/level-0/X86/x86-def.lisp @ 13067

Last change on this file since 13067 was 13067, checked in by rme, 10 years ago

Update copyright notices.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 25.8 KB
Line 
1;;; -*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2006-2009 Clozure Associates and contributors
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL 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#+x8664-target
19(progn
20
21(defx86lapfunction %function-vector-to-function ((arg arg_z))
22  (trap-unless-typecode= arg x8664::subtag-function)
23  (addb ($ (- x8664::fulltag-function x8664::fulltag-misc)) (% arg_z.b))
24  (single-value-return))
25
26(defx86lapfunction %function-to-function-vector  ((arg arg_z))
27  (trap-unless-fulltag= arg x8664::fulltag-function)
28  (subb ($ (- x8664::fulltag-function x8664::fulltag-misc)) (% arg_z.b))
29  (single-value-return))
30
31(defx86lapfunction %function-code-words ((fun arg_z))
32  (trap-unless-fulltag= fun x8664::fulltag-function)
33  (movl (@ (- x8664::node-size x8664::fulltag-function) (% fun)) (% imm0.l))
34  (box-fixnum imm0 arg_z)
35  (single-value-return))
36
37(defx86lapfunction %nth-immediate ((fun arg_y) (n arg_z))
38  (trap-unless-fulltag= fun x8664::fulltag-function)
39  (movl (@ (- x8664::node-size x8664::fulltag-function) (% fun)) (% imm0.l))
40  (lea (@ (% n) (% imm0) 8) (% imm0))
41  (movq (@ (- x8664::node-size x8664::fulltag-function) (% fun) (% imm0))
42        (% arg_z))
43  (single-value-return))
44
45(defx86lapfunction %set-nth-immediate ((fun arg_x) (n arg_y) (new arg_z))
46  (trap-unless-fulltag= fun x8664::fulltag-function)
47  (movl (@ (- x8664::node-size x8664::fulltag-function) (% fun)) (% imm0.l))
48  (lea (@ (% n) (% imm0) 8) (% arg_y))
49  (subb ($ (- x8664::fulltag-function x8664::fulltag-misc)) (%b arg_x))
50  (jmp-subprim .SPgvset))
51
52(defx86lapfunction %function-code-byte ((fun arg_y) (pc arg_z))
53  (unbox-fixnum pc imm0)
54  (movzbl (@ (% fun) (% imm0)) (% imm0.l))
55  (box-fixnum imm0 arg_z)
56  (single-value-return))
57
58
59;;; Returns 3 values: mask of registers used in the function, stack location
60;;; from which they'd be restored, relative PC at which they're saved. If
61;;; the mask is 0, the values NIL NIL NIL are returned. If either the stack
62;;; location or relative PC is #xff, both of those values will be returned
63;;; as NIL.
64(defx86lapfunction %function-register-usage ((f arg_z))
65  (check-nargs 1)
66  (trap-unless-fulltag= f x8664::fulltag-function)
67  (movzbl (@ -1 (% f)) (% imm0.l))
68  (shll ($ 8) (% imm0.l))
69  (box-fixnum imm0 arg_x)
70  (movq (% rsp) (% temp0))
71  (set-nargs 3)
72  (je @no-regs)
73  (movzbl (@ -2 (% f)) (% imm0.l))
74  (movzbl (@ -3 (% f)) (% imm1.l))
75  (cmpb ($ #xff) (% imm0.b))
76  (je @unencodable)
77  (cmpb ($ #xff) (% imm1.b))
78  (je @unencodable)
79  (box-fixnum imm0 arg_y)
80  (box-fixnum imm1 arg_z)
81  (push (% arg_x))
82  (push (% arg_y))
83  (push (% arg_z))
84  (jmp-subprim .SPvalues)
85  @unencodable
86  (push (% arg_x))
87  (pushq ($ nil))
88  (pushq ($ nil))
89  (jmp-subprim .SPvalues)
90  @no-regs
91  (pushq ($ nil))
92  (pushq ($ nil))
93  (pushq ($ nil))
94  (jmp-subprim .SPvalues))
95 
96       
97
98(defx86lapfunction %make-code-executable ((codev arg_z))
99  (single-value-return))
100
101;;; Make a new function, with PROTO's code and the specified immediates.
102;;; IMMEDIATES should contain lfun-bits as the last element.
103(defun %clone-x86-function (proto &rest immediates)
104  (declare (dynamic-extent immediates))
105  (let* ((protov (%function-to-function-vector proto))
106         (code-words (%function-code-words proto))
107         (numimms (length immediates))
108         (newv (allocate-typed-vector :function (the fixnum (+ code-words numimms)))))
109    (declare (fixnum code-words numimms))
110    (%copy-ivector-to-ivector protov 0 newv 0 (the fixnum (ash code-words target::word-shift)))
111    (do* ((k code-words (1+ k))
112          (imms immediates (cdr imms)))
113         ((null imms) (%function-vector-to-function newv))
114      (declare (fixnum k) (list imms))
115      (setf (%svref newv k) (car imms)))))
116
117(defun %copy-function (proto &optional target)
118  (let* ((protov (%function-to-function-vector proto))
119         (code-words (%function-code-words proto))
120         (total-words (uvsize protov))
121         (newv (if target
122                 (%function-to-function-vector target)
123                 (allocate-typed-vector :function total-words))))
124    (declare (fixnum code-words total-words))
125    (when target
126      (unless (and (eql code-words (%function-code-words target))
127                   (eql total-words (uvsize newv)))
128        (error "Wrong size target ~s" target)))
129    (%copy-ivector-to-ivector protov 0 newv 0 (the fixnum (ash code-words target::word-shift)))
130    (loop for k fixnum from code-words below total-words
131      do (setf (%svref newv k) (%svref protov k)))
132    (%function-vector-to-function newv)))
133
134(defun replace-function-code (target proto)
135  (let* ((target-words (%function-code-words target))
136         (proto-words (%function-code-words proto)))
137    (declare (fixnum target-words proto-words))
138    (if (= target-words proto-words)
139      (progn
140        (%copy-ivector-to-ivector (%function-to-function-vector proto)
141                                  0
142                                  (%function-to-function-vector target)
143                                  0
144                                  (the fixnum (ash target-words
145                                                   target::word-shift)))
146        target)
147      (error "Code size mismatch: target = ~s, proto = ~s"
148             target-words proto-words))))
149         
150
151(defx86lapfunction %get-kernel-global-from-offset ((offset arg_z))
152  (check-nargs 1)
153  (unbox-fixnum offset imm0)
154  (movq (@ (target-nil-value) (% imm0)) (% arg_z))
155  (single-value-return))
156
157(defx86lapfunction %set-kernel-global-from-offset ((offset arg_y) (new-value arg_z))
158  (check-nargs 2)
159  (unbox-fixnum offset imm0)
160  (movq (% arg_z) (@ (target-nil-value) (% imm0)))
161  (single-value-return))
162
163
164(defx86lapfunction %get-kernel-global-ptr-from-offset ((offset arg_y)
165                                                       (ptr arg_z))
166  (check-nargs 2)
167  (unbox-fixnum offset imm0)
168  (movq (@ (target-nil-value) (% imm0)) (% imm0))
169  (movq (% imm0) (@ x8664::macptr.address (% ptr)))
170  (single-value-return))
171
172
173
174
175(defx86lapfunction %fixnum-ref ((fixnum arg_y) #| &optional |# (offset arg_z))
176  (:arglist (fixnum &optional offset))
177  (check-nargs 1 2)
178  (cmpl ($ x8664::fixnumone) (% nargs))
179  (jne @2-args)
180  (movq (% offset) (% fixnum))
181  (xorl (%l offset) (%l offset))
182  @2-args
183  (unbox-fixnum offset imm0)
184  (movq (@ (% fixnum) (% imm0)) (% arg_z))
185  (single-value-return))
186
187(defx86lapfunction %fixnum-ref-natural ((fixnum arg_y) #| &optional |# (offset arg_z))
188  (:arglist (fixnum &optional offset))
189  (check-nargs 1 2)
190  (cmpl ($ x8664::fixnumone) (% nargs))
191  (jne @2-args)
192  (movq (% offset) (% fixnum))
193  (xorl (%l offset) (%l offset))
194  @2-args
195  (unbox-fixnum offset imm0)
196  (movq (@ (% fixnum) (% imm0)) (% imm0))
197  (jmp-subprim .SPmakeu64))
198
199(defx86lapfunction %fixnum-set ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z))
200  (:arglist (fixnum offset &optional newval))
201  (check-nargs 2 3)
202  (cmpl ($ '2) (% nargs))
203  (jne @3-args)
204  (movq (% offset) (% fixnum))
205  (xorl (%l offset) (%l offset))
206  @3-args
207  (unbox-fixnum offset imm0)
208  (movq (% new-value) (@ (% fixnum) (% imm0)))
209  (movq (% new-value) (% arg_z))
210  (single-value-return))
211
212
213(defx86lapfunction %fixnum-set-natural ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z))
214  (:arglist (fixnum offset &optional newval))
215  (check-nargs 2 3)
216  (save-simple-frame)
217  (cmpl ($ '2) (% nargs))
218  (jne @3-args)
219  (movq (% offset) (% fixnum))
220  (xorl (%l offset) (%l offset))
221  @3-args
222  (call-subprim .SPgetu64)
223  (unbox-fixnum offset imm1)
224  (movq (% imm0) (@ (% fixnum) (% imm1)))
225  (restore-simple-frame)
226  (single-value-return))
227
228
229(defx86lapfunction %current-frame-ptr ()
230  (check-nargs 0)
231  (movq (% rbp) (% arg_z))
232  (single-value-return))
233
234
235(defx86lapfunction %current-tsp ()
236  (check-nargs 0)
237  (movq (:rcontext x8664::tcr.save-tsp) (% arg_z))
238  (single-value-return))
239
240
241(defx86lapfunction %%frame-backlink ((p arg_z))
242  (check-nargs 1)
243  (movq (@ (% arg_z)) (% arg_z))
244  (single-value-return))
245
246;;; Look for "lea -nnnn(%rip),%fn" AT the tra; if that's present, use
247;;; the dispacement -nnnn to find the function.  The end of the
248;;; encoded displacement is
249;;; x8664::recover-fn-from-rip-disp-offset (= 7) bytes from the tra.
250(defx86lapfunction %return-address-function ((r arg_z))
251  (extract-lisptag r imm0)
252  (cmpb ($ x8664::tag-tra) (% imm0.b))
253  (jne @fail)
254  (cmpw ($ x8664::recover-fn-from-rip-word0) (@ (% r)))
255  (jne @fail)
256  (cmpb ($ x8664::recover-fn-from-rip-byte2) (@ 2 (% r)))
257  (movslq (@ x8664::recover-fn-from-rip-disp-offset (% r)) (% imm0))
258  (jne @fail)
259  (lea (@ x8664::recover-fn-from-rip-length (% imm0) (% r)) (% arg_z))
260  (single-value-return)
261  @fail
262  (movl ($ (target-nil-value)) (% arg_z.l))
263  (single-value-return))
264
265(defx86lapfunction %return-address-offset ((r arg_z))
266  (extract-lisptag r imm0)
267  (cmpb ($ x8664::tag-tra) (% imm0.b))
268  (jne @fail)
269  (cmpw ($ x8664::recover-fn-from-rip-word0) (@ (% r)))
270  (jne @fail)
271  (cmpb ($ x8664::recover-fn-from-rip-byte2) (@ 2 (% r)))
272  (movslq (@ x8664::recover-fn-from-rip-disp-offset (% r)) (% imm0))
273  (jne @fail)
274  (negq (% imm0))
275  (leaq (@ (- (ash x8664::recover-fn-from-rip-length x8664::fixnumshift)) (% imm0) 8) (% arg_z))
276  (single-value-return)
277  @fail
278  (movl ($ (target-nil-value)) (% arg_z.l))
279  (single-value-return))
280
281;;; It's always been the case that the function associated with a
282;;; frame pointer is the caller of the function that "uses" that frame.
283(defun %cfp-lfun (p)
284  (let* ((ra (%fixnum-ref p x8664::lisp-frame.return-address)))
285    (if (eq ra (%get-kernel-global ret1valaddr))
286      (setq ra (%fixnum-ref p x8664::lisp-frame.xtra)))
287    (values (%return-address-function ra) (%return-address-offset ra))))
288
289
290
291(defx86lapfunction %uvector-data-fixnum ((uv arg_z))
292  (check-nargs 1)
293  (trap-unless-fulltag= arg_z x8664::fulltag-misc)
294  (addq ($ x8664::misc-data-offset) (% arg_z))
295  (single-value-return))
296
297(defx86lapfunction %catch-top ((tcr arg_z))
298  (check-nargs 1)
299  (movl ($ (target-nil-value)) (%l arg_y))
300  (movq (:rcontext x8664::tcr.catch-top) (% arg_z))
301  (testb (%b arg_z) (%b arg_z))
302  (cmoveq (% arg_y) (% arg_z))
303  (single-value-return))
304
305(defx86lapfunction %catch-tsp ((catch arg_z))
306  (check-nargs 1)
307  (lea (@  (- (+ target::fulltag-misc
308                                 (ash 1 (1+ target::word-shift)))) (% arg_z))
309       (% arg_z))
310  (single-value-return))
311
312
313
314;;; Same as %address-of, but doesn't cons any bignums
315;;; It also left shift fixnums just like everything else.
316(defx86lapfunction %fixnum-address-of ((x arg_z))
317  (check-nargs 1)
318  (box-fixnum x arg_z)
319  (single-value-return))
320
321(defx86lapfunction %save-standard-binding-list ((bindings arg_z))
322  (movq (:rcontext x8664::tcr.vs-area) (% imm0))
323  (movq (@ x8664::area.high (% imm0)) (% imm1))
324  (subq ($ x8664::node-size) (% imm1))
325  (movq (% bindings) (@ (% imm1)))
326  (single-value-return))
327
328(defx86lapfunction %saved-bindings-address ()
329  (movq (:rcontext x8664::tcr.vs-area) (% imm0))
330  (movq (@ x8664::area.high (% imm0)) (% imm1))
331  (lea (@ (- x8664::node-size) (% imm1)) (% arg_z))
332  (single-value-return))
333
334(defx86lapfunction %get-object ((macptr arg_y) (offset arg_z))
335  (check-nargs 2)
336  (trap-unless-typecode= macptr x8664::subtag-macptr)
337  (macptr-ptr macptr imm0)
338  (trap-unless-lisptag= offset target::tag-fixnum imm1)
339  (unbox-fixnum offset imm1)
340  (movq (@ (% imm0) (% imm1)) (% arg_z))
341  (single-value-return))
342
343
344(defx86lapfunction %set-object ((macptr arg_x) (offset arg_y) (value arg_z))
345  (check-nargs 3)
346  (trap-unless-typecode= macptr target::subtag-macptr)
347  (macptr-ptr macptr imm0)
348  (trap-unless-lisptag= offset target::tag-fixnum imm1)
349  (unbox-fixnum offset imm1)
350  (movq (% arg_z) (@ (% imm0) (% imm1)))
351  (single-value-return))
352
353(defx86lapfunction %apply-lexpr-with-method-context ((magic arg_x)
354                                                     (function arg_y)
355                                                     (args arg_z))
356  ;; Somebody's called (or tail-called) us.
357  ;; Put magic arg in x8664::next-method-context (= x8664::temp0).
358  ;; Put function in x8664::xfn until we're ready to jump to it.
359  ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z,
360  ;;   but preserves x866::xfn/x8664::next-method-context.
361  ;; Jump to the function in x8664::xfn.
362  (popq (% ra0))
363  (movq (% magic) (% next-method-context))
364  (movq (% function) (% xfn))
365  (set-nargs 0)
366  (movq (@ (% args)) (% imm0))          ;lexpr-count
367  (movl (%l imm0) (% nargs))
368  (leaq (@ x8664::node-size (% arg_z) (% imm0)) (% imm1))
369  (subl ($ '3) (% imm0))
370  (jbe @reg-only)
371  ;; Some args will be pushed; reserve a frame
372  (pushq ($ x8664::reserved-frame-marker))
373  (pushq ($ x8664::reserved-frame-marker))
374  @pushloop
375  (pushq (@ (- x8664::node-size) (% imm1)))
376  (subq ($ x8664::node-size) (% imm1))
377  (subq ($ x8664::node-size) (% imm0))
378  (jne @pushloop)
379  @three
380  (movq (@ (* x8664::node-size 3) (% arg_z)) (% arg_x))
381  @two
382  (movq (@ (* x8664::node-size 2) (% arg_z)) (% arg_y))
383  @one
384  (movq (@ (* x8664::node-size 1) (% arg_z)) (% arg_z))
385  (jmp @go)
386  @reg-only
387  (testl (% nargs) (% nargs))
388  (je @go)
389  (rcmpl (% nargs) ($ '2))
390  (je @two)
391  (jb @one)
392  (jmp @three)
393  @go
394  (push (% ra0))
395  (jmp (% xfn)))
396
397(defx86lapfunction %apply-with-method-context ((magic arg_x)
398                                               (function arg_y)
399                                               (args arg_z))
400  ;; Somebody's called (or tail-called) us.
401  ;; Put magic arg in x8664::next-method-context (= x8664::temp0).
402  ;; Put function in x8664::xfn (= x8664::temp1).
403  ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z,
404  ;;   but preserves x8664::xfn/x8664::next-method-context.
405  ;; Jump to the function in x8664::xfn.
406  (pop (% ra0)) 
407  (movq (% magic) (% x8664::next-method-context))
408  (movq (% function) (% x8664::xfn))
409  (movq (% args) (% arg_y))             ; in case of error
410  (set-nargs 0)
411  (xorl (% imm0.l) (% imm0.l))
412  (push (% imm0))                       ; reserve frame (might discard
413  (push (% imm0))                       ; it if nothing is passed on stack.)
414  (cmp-reg-to-nil arg_z)
415  (je @done)
416  @loop
417  (extract-fulltag arg_z imm1)
418  (cmpb ($ x8664::fulltag-cons) (%b imm1))
419  (jne @bad)
420  (%car arg_z arg_x)
421  (%cdr arg_z arg_z)
422  (lea (@ x8664::node-size (% imm0)) (% imm0))
423  (cmp-reg-to-nil arg_z)
424  (push (% arg_x))
425  (jne @loop)
426  @done
427  (addl (%l imm0) (% nargs))
428  (jne @pop)
429  @discard-and-go
430  (discard-reserved-frame)
431  (jmp @go)
432  @pop
433  (cmpl($ '1) (% nargs))
434  (pop (% arg_z))
435  (je @discard-and-go)
436  (cmpl ($ '2) (% nargs))
437  (pop (% arg_y))
438  (je @discard-and-go)
439  (cmpl ($ '3) (% nargs))
440  (pop (% arg_x))
441  (je @discard-and-go)
442  @go
443  (push (% ra0))
444  (jmp (% xfn))
445  @bad
446  (addq (% imm0) (% rsp))
447  (movq (% arg_y) (% arg_z))
448  (movq ($ (ash $XNOSPREAD x8664::fixnumshift)) (% arg_y))
449  (set-nargs 2)
450  (jmp-subprim .SPksignalerr))
451
452
453;;; The idea here is to call METHOD in the same stack frame in
454;;; which the lexpr was originally called.  The lexpr can't
455;;; have had any required arguments, %APPLY-LEXPR-TAIL-WISE
456;;; must have been tail-called, and the frame built on lexpr
457;;; entry must be in %rbp.
458(defx86lapfunction %apply-lexpr-tail-wise ((method arg_y) (args arg_z))
459  (addq ($ x8664::node-size) (% rsp))   ; discard extra return address
460  (movq (% method) (% xfn))
461  (movq (% args) (% rsp))
462  (pop (%q nargs))
463  (movq (@ x8664::lisp-frame.return-address (% rbp)) (% ra0))
464  (movq (@ 0 (% rbp)) (% rbp))
465  (rcmpl (% nargs) ($ '3))
466  (jbe @pop-regs)
467  ;; More than 3 args; some must have been pushed by caller,
468  ;; so retain the reserved frame.
469  (pop (% arg_z))
470  (pop (% arg_y))
471  (pop (% arg_x))
472  (jmp @popped)
473  @pop-regs
474  (je @pop3)
475  (rcmpl (% nargs) ($ '1))
476  (jb @discard)
477  (ja @pop2)
478  (pop (% arg_z))
479  (jmp @discard)
480  @pop3
481  (pop (% arg_z))
482  (pop (% arg_y))
483  (pop (% arg_x))
484  (jmp @discard)
485  @pop2
486  (pop (% arg_z))
487  (pop (% arg_y))
488  @discard
489  (discard-reserved-frame)
490  @popped
491  (push (% ra0))
492  (jmp (% xfn)))
493
494
495
496(defun closure-function (fun)
497  (while (and (functionp fun)  (not (compiled-function-p fun)))
498    (setq fun (%nth-immediate fun 0))
499    (when (vectorp fun)
500      (setq fun (svref fun 0))))
501  fun)
502
503;;; For use by (setf (apply ...) ...)
504;;; (apply+ f butlast last) = (apply f (append butlast (list last)))
505
506(defun apply+ (&lap function arg1 arg2 &rest other-args)
507  (x86-lap-function apply+ ()
508   (:arglist (function arg1 arg2 &rest other-args))
509   (check-nargs 3 nil)
510   (cmpl ($ '3) (% nargs))
511   (pop (% ra0))
512   (ja @no-frame)
513   (pushq ($ x8664::reserved-frame-marker))
514   (pushq ($ x8664::reserved-frame-marker))
515@no-frame         
516   (push (% arg_x))
517   (movq (% arg_z) (% temp0))           ; last
518   (movq (% arg_y) (% arg_z))           ; butlast
519   (subl ($ '2) (% nargs))              ; remove count for butlast & last
520   ;; Do .SPspreadargz inline here
521   (xorl (%l imm0) (%l imm0))
522   (movq (% arg_z) (% arg_y))           ; save in case of error
523   (cmp-reg-to-nil arg_z)
524   (je @done)
525   @loop
526   (extract-fulltag arg_z imm1)
527   (cmpb ($ x8664::fulltag-cons) (%b imm1))
528   (jne @bad)
529   (%car arg_z arg_x)
530   (%cdr arg_z arg_z)
531   (addl ($ '1) (%l imm0))
532   (cmp-reg-to-nil arg_z)   
533   (push (% arg_x))
534   (jne @loop)
535   @done
536   ;; nargs was at least 1 when we started spreading, and can't have gotten
537   ;; any smaller.
538   (addl (%l imm0) (% nargs))
539   (movq (% temp0) (% arg_z))
540   (pop (% arg_y))
541   (pop (% arg_x))
542   (addl ($ '1) (% nargs))
543   (cmpl ($ '3) (% nargs))
544   (jne @no-discard)
545   (discard-reserved-frame)
546   @no-discard
547   (load-constant funcall temp0)
548   (push (% ra0))
549   (jmp-subprim .SPfuncall)
550   @bad                                 ; error spreading list.
551   (add (% imm0) (% rsp))               ; discard whatever's been pushed
552   (movq (% arg_y) (% arg_z))
553   (movl ($ '#.$XNOSPREAD) (%l arg_y))
554   (set-nargs 2)
555   (jmp-subprim .SPksignalerr) ))
556
557
558
559;;; This needs to:
560;;; (a) load FP arg regs from the FP-REGS argument
561;;; (b) call the .SPffcall subprimitive, which will discard the foreign stack frame
562;;;     allocated by WITH-VARIABLE-C-FRAME in %FF-CALL
563;;; (c) re-establish the same foreign stack frame and store the result regs
564;;;     (%rax/%xmm0) there
565(defx86lapfunction %do-ff-call ((nfp 0) (frame arg_x) (fp-regs arg_y) (entry arg_z))
566  (popq (% ra0))
567  (popq (% rax))
568  (movq (% rbp) (@  (% rsp)))
569  (movq (% rsp) (% rbp))
570  (movq (% ra0) (@ 8 (% rbp)))
571  (macptr-ptr fp-regs temp0)
572  (sarq ($ x8664::fixnumshift) (% rax))
573  (movq (@ (% temp0)) (% fp0))
574  (movq (@ 8 (% temp0)) (% fp1))
575  (movq (@ 16 (% temp0)) (% fp2))
576  (movq (@ 24 (% temp0)) (% fp3))
577  (movq (@ 32 (% temp0)) (% fp4))
578  (movq (@ 40 (% temp0)) (% fp5))
579  (movq (@ 48 (% temp0)) (% fp6))
580  (movq (@ 56 (% temp0)) (% fp7))
581  (call-subprim .SPffcall)
582  (movq (:rcontext x8664::tcr.foreign-sp) (% mm5))
583  (movq (% mm5) (@ (% frame)))
584  (movq (% frame) (:rcontext x8664::tcr.foreign-sp))
585  (movq (% rax) (@ 8 (% frame)))
586  (movq (% fp0) (@ 16 (% frame)))
587  (movl ($ nil) (%l arg_z))
588  (restore-simple-frame)
589  (single-value-return))
590
591(defx86lapfunction %do-ff-call-return-registers ((fp-regs 8)(nfp 0) (frame arg_x) (regbuf arg_y) (entry arg_z))
592  (popq (% ra0))
593  (popq (% rax))
594  (popq (% temp0))
595  (movq (% rbp) (@  (% rsp)))
596  (movq (% rsp) (% rbp))
597  (movq (% ra0) (@ 8 (% rbp)))
598  (macptr-ptr temp0 temp0)
599  (sarq ($ x8664::fixnumshift) (% rax))
600  (movq (@ (% temp0)) (% fp0))
601  (movq (@ 8 (% temp0)) (% fp1))
602  (movq (@ 16 (% temp0)) (% fp2))
603  (movq (@ 24 (% temp0)) (% fp3))
604  (movq (@ 32 (% temp0)) (% fp4))
605  (movq (@ 40 (% temp0)) (% fp5))
606  (movq (@ 48 (% temp0)) (% fp6))
607  (movq (@ 56 (% temp0)) (% fp7))
608  (call-subprim .SPffcall-return-registers)
609  (movq (:rcontext x8664::tcr.foreign-sp) (% mm5))
610  (movq (% mm5) (@ (% frame)))
611  (movq (% frame) (:rcontext x8664::tcr.foreign-sp))
612  (movl ($ nil) (%l arg_z))
613  (restore-simple-frame)
614  (single-value-return))
615 
616
617(defun %ff-call (entry &rest specs-and-vals)
618  (declare (dynamic-extent specs-and-vals))
619  (let* ((len (length specs-and-vals))
620         (total-words 0)
621         (regbuf nil))
622    (declare (fixnum len total-words))
623    (let* ((result-spec (or (car (last specs-and-vals)) :void))
624           (nargs (ash (the fixnum (1- len)) -1))
625           (n-fp-args 0))
626      (declare (fixnum nargs n-fp-args))
627      (ecase result-spec
628        ((:address :unsigned-doubleword :signed-doubleword
629                   :single-float :double-float
630                   :signed-fullword :unsigned-fullword
631                   :signed-halfword :unsigned-halfword
632                   :signed-byte :unsigned-byte
633                   :void)
634         (do* ((i 0 (1+ i))
635               (specs specs-and-vals (cddr specs))
636               (spec (car specs) (car specs)))
637              ((= i nargs))
638           (declare (fixnum i))
639           (case spec
640             ((:address :unsigned-doubleword :signed-doubleword
641                        :single-float :double-float
642                        :signed-fullword :unsigned-fullword
643                        :signed-halfword :unsigned-halfword
644                        :signed-byte :unsigned-byte)
645              (incf total-words))
646             (:registers )
647             (t (if (typep spec 'unsigned-byte)
648                  (incf total-words spec)
649                  (error "unknown arg spec ~s" spec)))))
650         ;; It's necessary to ensure that the C frame is the youngest thing on
651         ;; the foreign stack here.
652         (%stack-block ((fp-args (* 8 8)))
653           (with-macptrs ((argptr))
654             (with-variable-c-frame
655                 total-words frame
656                 (%setf-macptr-to-object argptr frame)
657                 (let* ((gpr-offset 16)
658                        (other-offset (+ gpr-offset (* 6 8))))
659                   (declare (fixnum gpr-offset other-offset))
660                   (do* ((i 0 (1+ i))
661                         (ngpr-args 0)
662                         (specs specs-and-vals (cddr specs))
663                         (spec (car specs) (car specs))
664                         (val (cadr specs) (cadr specs)))
665                        ((= i nargs))
666                     (declare (fixnum i))
667                     (case spec
668                       (:address
669                        (incf ngpr-args)
670                        (cond ((<= ngpr-args 6)
671                               (setf (%get-ptr argptr gpr-offset) val)
672                               (incf gpr-offset 8))
673                              (t
674                               (setf (%get-ptr argptr other-offset) val)
675                               (incf other-offset 8))))
676                       ((:signed-doubleword :signed-fullword :signed-halfword
677                                            :signed-byte)
678                        (incf ngpr-args)
679                        (cond ((<= ngpr-args 6)
680                               (setf (%%get-signed-longlong argptr gpr-offset) val)
681                               (incf gpr-offset 8))
682                              (t
683                               (setf (%%get-signed-longlong argptr other-offset) val)
684                               (incf other-offset 8))))
685                       ((:unsigned-doubleword :unsigned-fullword :unsigned-halfword
686                                              :unsigned-byte)
687                        (incf ngpr-args)
688                        (cond ((<= ngpr-args 6)
689                               (setf (%%get-unsigned-longlong argptr gpr-offset) val)
690                               (incf gpr-offset 8))
691                              (t
692                               (setf (%%get-unsigned-longlong argptr other-offset) val)
693                               (incf other-offset 8))))
694                       (:double-float
695                        (cond ((< n-fp-args 8)
696                               (setf (%get-double-float fp-args (* n-fp-args 8)) val)
697                               (incf n-fp-args))
698                              (t
699                               (setf (%get-double-float argptr other-offset) val)
700                               (incf other-offset 8))))
701                       (:single-float
702                        (cond ((< n-fp-args 8)
703                               (setf (%get-single-float fp-args (* n-fp-args 8))
704                                     val)
705                               (incf n-fp-args))
706                              (t 
707                               (setf (%get-single-float argptr other-offset) val)
708                               (incf other-offset 8))))
709                       (:registers (setq regbuf val))
710                       (t
711                        (let* ((p 0))
712                          (declare (fixnum p))
713                          (dotimes (i (the fixnum spec))
714                            (setf (%get-ptr argptr other-offset) (%get-ptr val p))
715                            (incf p 8)
716                            (incf other-offset 8)))))))
717                 (if regbuf
718                   (%do-ff-call-return-registers fp-args (min n-fp-args 8) frame regbuf entry)
719                   (%do-ff-call (min n-fp-args 8) frame fp-args entry))
720                 (ecase result-spec
721                   (:void nil)
722                   (:address (%get-ptr argptr 8))
723                   (:unsigned-byte (%get-unsigned-byte argptr 8))
724                   (:signed-byte (%get-signed-byte argptr 8))
725                   (:unsigned-halfword (%get-unsigned-word argptr 8))
726                   (:signed-halfword (%get-signed-word argptr 8))
727                   (:unsigned-fullword (%get-unsigned-long argptr 8))
728                   (:signed-fullword (%get-signed-long argptr 8))
729                   (:unsigned-doubleword (%get-natural argptr 8))
730                   (:signed-doubleword (%get-signed-natural argptr 8))
731                   (:single-float (%get-single-float argptr 16))
732                   (:double-float (%get-double-float argptr 16)))))))))))
733                                 
734
735;;; end of x86-def.lisp
736) ; #+x8664-target
Note: See TracBrowser for help on using the repository browser.