source: branches/win64/level-0/X86/x86-def.lisp @ 8649

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

Use (:rcontext tcr-field) syntax to reference TCR fields.
Don't use SAVE3 (was used for debugging of heap-walking code; might
be used in %%APPLY-IN-FRAME-PROTO if caller sets it.)

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