source: branches/ia32/level-0/X86/X8632/x8632-def.lisp @ 9127

Last change on this file since 9127 was 9127, checked in by rme, 12 years ago

Implement %clone-x86-function, replace-function-code. (These are almost
exactly the same and the x8664 versions, and should probably be merged.)

%apply-lexpr-tail-wise: do the register shuffle...

File size: 21.6 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;;; Use the offsets in a function's self-reference table to replace
20;;; the :self in (movl ($ :self) (% fn)) wih the function's actual
21;;; address.
22(defx8632lapfunction %update-self-references ((fun arg_z))
23  (movzwl (@ x8632::misc-data-offset (% fun)) (% imm0)) ;imm word count
24  (subl ($ 2) (% imm0))
25  (box-fixnum imm0 temp0)               ;byte offset of first self-ref offset
26  (jmp @load-offset)
27  @loop
28  (movl (% fun) (@ x8632::misc-header-offset (% fun) (% imm0)))
29  (subl ($ '1) (% temp0))
30  @load-offset
31  (movl (@ x8632::misc-data-offset (% fun) (% temp0)) (% imm0))
32  (test (% imm0) (% imm0))
33  (jne @loop)
34  (single-value-return))
35
36(defx8632lapfunction %function-vector-to-function ((arg arg_z))
37  (single-value-return))
38
39(defx8632lapfunction %function-to-function-vector  ((arg arg_z))
40  (single-value-return))
41
42(defx8632lapfunction %function-code-words ((fun arg_z))
43  (trap-unless-typecode= fun x8632::subtag-function)
44  (movzwl (@ x8632::misc-data-offset (% fun)) (% imm0))
45  (box-fixnum imm0 arg_z)
46  (single-value-return))
47
48(defx8632lapfunction %nth-immediate ((fun arg_y) (n arg_z))
49  (trap-unless-typecode= fun x8632::subtag-function)
50  (movzwl (@ x8632::misc-data-offset (% fun)) (% imm0))
51  (lea (@ (% n) (% imm0) 4) (% imm0))
52  (movl (@ x8632::misc-data-offset (% fun) (% imm0)) (% arg_z))
53  (single-value-return))
54
55(defx8632lapfunction %set-nth-immediate ((fun 4) #|(ra 0)|# (n arg_y) (new arg_z))
56  (popl (@ 8 (% esp)))
57  (popl (% temp0))
58  (addl ($ 4) (% esp))
59  (trap-unless-typecode= temp0 x8632::subtag-function)
60  (movzwl (@ x8632::misc-data-offset (% temp0)) (% imm0))
61  (lea (@ (% n) (% imm0) 4) (% arg_y))
62  ;; expects gvector in temp0
63  (jmp-subprim .SPgvset))
64
65(defx8632lapfunction %function-code-byte ((fun arg_y) (pc arg_z))
66  (unbox-fixnum pc imm0)
67  (movzbl (@ (% fun) (% imm0)) (% imm0))
68  (box-fixnum imm0 arg_z)
69  (single-value-return))
70
71;;; XXX probably should unify these next two with the x8664 versions.
72
73;;; Make a new function, with PROTO's code and the specified immediates.
74;;; IMMEDIATES should contain lfun-bits as the last element.
75(defun %clone-x86-function (proto &rest immediates)
76  (declare (dynamic-extent immediates))
77  (let* ((protov (%function-to-function-vector proto))
78         (code-words (%function-code-words proto))
79         (numimms (length immediates))
80         (newv (allocate-typed-vector :function (the fixnum (+ code-words numimms)))))
81    (declare (fixnum code-words numimms))
82    (%copy-ivector-to-ivector protov 0 newv 0 (the fixnum (ash code-words target::word-shift)))
83    (%update-self-references newv)
84    (do* ((k code-words (1+ k))
85          (imms immediates (cdr imms)))
86         ((null imms) (%function-vector-to-function newv))
87      (declare (fixnum k) (list imms))
88      (setf (%svref newv k) (car imms)))))
89
90(defun replace-function-code (target proto)
91  (let* ((target-words (%function-code-words target))
92         (proto-words (%function-code-words proto)))
93    (declare (fixnum target-words proto-words))
94    (if (= target-words proto-words)
95      (progn
96        (%copy-ivector-to-ivector (%function-to-function-vector proto)
97                                  0
98                                  (%function-to-function-vector target)
99                                  0
100                                  (the fixnum (ash target-words
101                                                   target::word-shift)))
102        (%update-self-references target)
103        target)
104      (error "Code size mismatch: target = ~s, proto = ~s"
105             target-words proto-words))))
106
107(defx8632lapfunction %get-kernel-global-from-offset ((offset arg_z))
108  (check-nargs 1)
109  (unbox-fixnum offset imm0)
110  (movl (@ x8632::nil-value (% imm0)) (% arg_z))
111  (single-value-return))
112
113(defx8632lapfunction %set-kernel-global-from-offset ((offset arg_y)
114                                                     (new-value arg_z))
115  (check-nargs 2)
116  (unbox-fixnum offset imm0)
117  (movl (% arg_z) (@ x8632::nil-value (% imm0)))
118  (single-value-return))
119
120(defx8632lapfunction %get-kernel-global-ptr-from-offset ((offset arg_y)
121                                                         (ptr arg_z))
122  (check-nargs 2)
123  (unbox-fixnum offset imm0)
124  (movl (@ x8632::nil-value (% imm0)) (% imm0))
125  (movl (% imm0) (@ x8632::macptr.address (% ptr)))
126  (single-value-return))
127
128(defx8632lapfunction %fixnum-ref ((fixnum arg_y) #| &optional |# (offset arg_z))
129  (:arglist (fixnum &optional offset))
130  (check-nargs 1 2)
131  (cmpl ($ x8632::fixnumone) (% nargs))
132  (jne @2-args)
133  (movl (% offset) (% fixnum))
134  (xorl (%l offset) (%l offset))
135  @2-args
136  (unbox-fixnum offset imm0)
137  (movl (@ (% fixnum) (% imm0)) (% arg_z))
138  (single-value-return))
139
140(defx8632lapfunction %fixnum-ref-natural ((fixnum arg_y) #| &optional |# (offset arg_z))
141  (:arglist (fixnum &optional offset))
142  (check-nargs 1 2)
143  (cmpl ($ x8632::fixnumone) (% nargs))
144  (jne @2-args)
145  (movl (% offset) (% fixnum))
146  (xorl (%l offset) (%l offset))
147  @2-args
148  (unbox-fixnum offset imm0)
149  (movl (@ (% fixnum) (% imm0)) (% imm0))
150  (jmp-subprim .SPmakeu32))
151
152(defx8632lapfunction %fixnum-set ((fixnum 4) #|(ra 0)|# (offset arg_y) #| &optional |# (new-value arg_z))
153  (:arglist (fixnum offset &optional newval))
154  (check-nargs 2 3)
155  (movl (@ fixnum (% esp)) (% temp0))
156  (cmpl ($ '2) (% nargs))
157  (jne @3-args)
158  (movl (% offset) (% temp0))
159  (xorl (%l offset) (%l offset))
160  @3-args
161  (unbox-fixnum offset imm0)
162  (movl (% new-value) (@ (% temp0) (% imm0)))
163  (movl (% new-value) (% arg_z))
164  (single-value-return 3))
165
166
167(defx8632lapfunction %fixnum-set-natural ((fixnum 4) #|(ra 0)|# (offset arg_y) #| &optional |# (new-value arg_z))
168  (:arglist (fixnum offset &optional newval))
169  (check-nargs 2 3)
170  (movl (@ fixnum (% esp)) (% temp0))
171  (save-simple-frame)
172  (cmpl ($ '2) (% nargs))
173  (jne @3-args)
174  (movl (% offset) (% temp0))
175  (xorl (%l offset) (%l offset))
176  @3-args
177  (call-subprim .SPgetu32)              ;puts u32 in imm0
178  (mark-as-imm temp1)
179  (unbox-fixnum offset temp1)
180  (movl (% imm0) (@ (% temp0) (% temp1)))
181  (mark-as-node temp1)
182  (restore-simple-frame)
183  (single-value-return 3))
184
185
186(defx8632lapfunction %current-frame-ptr ()
187  (check-nargs 0)
188  (movl (% ebp) (% arg_z))
189  (single-value-return))
190
191
192(defx8632lapfunction %current-tsp ()
193  (check-nargs 0)
194  (movl (@ (% :rcontext) x8632::tcr.save-tsp) (% arg_z))
195  (single-value-return))
196
197
198(defx8632lapfunction %%frame-backlink ((p arg_z))
199  (check-nargs 1)
200  (movl (@ (% arg_z)) (% arg_z))
201  (single-value-return))
202
203;;; Look for "movl $imm32,%fn at the tra;  if present, then $imm32 is
204;;; the address of the function.
205;;;
206;;; That is: #b10111111 <imm32>
207;;;                ^^^^
208;;;   operand size || register number (%fn/%edi)
209
210(defx8632lapfunction %return-address-function ((r arg_z))
211  (extract-lisptag r imm0)
212  (cmpb ($ x8632::fulltag-tra) (% imm0.b))
213  (jne @fail)
214  (cmpb ($ x8632::recover-fn-opcode-byte) (@ (% r)))
215  (jne @fail)
216  (movl (@ x8632::recover-fn-address-offset (% r)) (% arg_z))
217  (single-value-return)
218  @fail
219  (movl ($ x8632::nil-value) (% arg_z))
220  (single-value-return))
221
222;;; xxx this may need twiddling to refer to the right place
223(defx8632lapfunction %return-address-offset ((r arg_z))
224  (extract-lisptag r imm0)
225  (cmpb ($ x8632::fulltag-tra) (% imm0.b))
226  (jne @fail)
227  (cmpb ($ x8632::recover-fn-opcode-byte) (@ (% r)))
228  (jne @fail)
229  (movl (@ x8632::recover-fn-address-offset (% r)) (% imm0))
230  (subl (% arg_z) (% imm0))             ;offset = tra - fn
231  (box-fixnum imm0 arg_z)
232  @fail
233  (movl ($ x8632::nil-value) (% arg_z))
234  (single-value-return))
235
236;;; It's always been the case that the function associated with a
237;;; frame pointer is the caller of the function that "uses" that frame.
238(defun %cfp-lfun (p)
239  (let* ((ra (%fixnum-ref p x8632::lisp-frame.return-address)))
240    (if (eq ra (%get-kernel-global ret1valaddr))
241      (setq ra (%fixnum-ref p x8632::lisp-frame.xtra)))
242    (values (%return-address-function ra) (%return-address-offset ra))))
243
244(defx8632lapfunction %uvector-data-fixnum ((uv arg_z))
245  (check-nargs 1)
246  (trap-unless-fulltag= arg_z x8632::fulltag-misc)
247  (addl ($ x8632::misc-data-offset) (% arg_z))
248  (single-value-return))
249
250(defx8632lapfunction %catch-top ((tcr arg_z))
251  (check-nargs 1)
252  (movl ($ x8632::nil-value) (% arg_y))
253  (movl (@ (% :rcontext) x8632::tcr.catch-top) (% arg_z))
254  (testb (%b arg_z) (%b arg_z))
255  (cmovel (% arg_y) (% arg_z))
256  (single-value-return))
257
258(defx8632lapfunction %catch-tsp ((catch arg_z))
259  (check-nargs 1)
260  (lea (@  (- (+ x8632::fulltag-misc
261                 (ash 1 (1+ x8632::word-shift)))) (% arg_z))
262       (% arg_z))
263  (single-value-return))
264
265;;; Same as %address-of, but doesn't cons any bignums
266;;; It also left shift fixnums just like everything else.
267(defx8632lapfunction %fixnum-address-of ((x arg_z))
268  (check-nargs 1)
269  (box-fixnum x arg_z)
270  (single-value-return))
271
272(defx8632lapfunction %save-standard-binding-list ((bindings arg_z))
273  (mark-as-imm temp0)
274  (movl (@ (% :rcontext) x8632::tcr.vs-area) (% imm0))
275  (movl (@ x8632::area.high (% imm0)) (% temp0))
276  (subl ($ x8632::node-size) (% temp0))
277  (movl (% bindings) (@ (% temp0)))
278  (mark-as-node temp0)
279  (single-value-return))
280
281(defx8632lapfunction %saved-bindings-address ()
282  (mark-as-imm temp0)
283  (movl (@ (% :rcontext) x8632::tcr.vs-area) (% imm0))
284  (movl (@ x8632::area.high (% imm0)) (% temp0))
285  (leal (@ (- x8632::node-size) (% temp0)) (% arg_z))
286  (mark-as-node temp0)
287  (single-value-return))
288
289(defx8632lapfunction %get-object ((macptr arg_y) (offset arg_z))
290  (check-nargs 2)
291  (trap-unless-typecode= macptr x8632::subtag-macptr)
292  (trap-unless-lisptag= offset x8632::tag-fixnum)
293  (macptr-ptr macptr imm0)
294  (mark-as-imm temp0)
295  (unbox-fixnum offset temp0)
296  (movl (@ (% imm0) (% temp0)) (% arg_z))
297  (mark-as-node temp0)
298  (single-value-return))
299
300(defx8632lapfunction %set-object ((macptr 4) #|(ra 0)|# (offset arg_y) (value arg_z))
301  (check-nargs 3)
302  (movl (@ macptr (% esp)) (% temp1))
303  (trap-unless-typecode= temp1 x8632::subtag-macptr)
304  (trap-unless-lisptag= offset x8632::tag-fixnum)
305  (macptr-ptr temp1 imm0)
306  (mark-as-imm temp0)
307  (unbox-fixnum offset temp0)
308  (movl (% arg_z) (@ (% imm0) (% temp0)))
309  (mark-as-node temp0)
310  (single-value-return 3))
311
312(defx8632lapfunction %apply-lexpr-with-method-context ((magic 4)
313                                                       #|(ra 0)|#
314                                                       (function arg_y)
315                                                       (args arg_z))
316  (int ($ 3))
317  ;; Somebody's called (or tail-called) us.
318  ;; * Put magic arg in x8632::next-method-context (= x8632::temp0).
319  ;; * Put function in x8632::xfn ( = x8632::temp1) until we're ready to
320  ;;   jump to it.
321  ;; * Set nargs to 0, then spread "args" on stack (clobbers arg_y,
322  ;;   arg_z, but preserves x8632::xfn/x8632::next-method-context. Note
323  ;;   that nargs and temp1 are the same register on x8632.
324  ;; * Jump to the function in x8632::xfn.
325  ;; These steps are done in a mixed up order on x8632 because of
326  ;; the small number of registers.
327  (popl (@ (% :rcontext) x8632::tcr.save0))     ;save return address,
328  (popl (@ (% :rcontext) x8632::tcr.save1))     ;magic arg, and
329  (movl (% function) (@ (% :rcontext) x8632::tcr.save2)) ;function in spill area
330  (set-nargs 0)
331  (movl (@ (% args)) (% temp0))         ;lexpr-count
332  (movl (% temp0) (% nargs))
333  (leal (@ x8632::node-size (% arg_z) (% temp0)) (% imm0))
334  (subl ($ '2) (% imm0))
335  (jbe @reg-only)
336  ;; Some args will be pushed; reserve a frame.
337  (pushl ($ x8632::reserved-frame-marker))
338  (pushl ($ x8632::reserved-frame-marker))
339  @pushloop
340  (pushl (@ (- x8632::node-size) (% imm0)))
341  (subl ($ x8632::node-size) (% imm0))
342  (subl ($ x8632::node-size) (% temp0))
343  (jne @pushloop)
344  @two
345  (movl (@ (* x8632::node-size 2) (% arg_z)) (% arg_y))
346  @one
347  (movl (@ (* x8632::node-size 1) (% arg_z)) (% arg_z))
348  (jmp @go)
349  @reg-only
350  (rcmp (% nargs) ($ '1))               ;note that nargs is temp1
351  (je @one)
352  (jb @go)
353  (jmp @two)
354  @go
355  (movl (@ (% :rcontext) x8632::tcr.save1) (% next-method-context)) ;aka temp0
356  (pushl (@ (% :rcontext) x8632::tcr.save0))     ;return address
357  (movsd (% fpzero) (@ (% :rcontext) x8632::tcr.save0)) ;clear out save0/save1
358  (movl (@ (% :rcontext) x8632::tcr.save2) (% imm0))
359  ;; xxx if otherwise garbage, function might stick around until someone else
360  ;; zeroes the spill area
361  (jmp (% imm0)))
362
363(defx8632lapfunction %apply-with-method-context ((magic 4)
364                                                 #|(ra 0)|#
365                                                 (function arg_y)
366                                                 (args arg_z))
367  (int ($ 3))
368  ;; Similar to above.
369  (popl (@ (% :rcontext) x8632::tcr.save0))     ;save return address
370  (popl (@ (% :rcontext) x8632::tcr.save1))     ; and magic arg in the spill area
371  (movl (% args) (@ (% :rcontext) x8632::tcr.save2))    ;in case of error
372  (xorl (% imm0) (% imm0))
373  (push (% imm0))               ;reserve frame (might discard it
374  (push (% imm0))               ;if nothing is passed on stack)
375  (cmp-reg-to-nil arg_z)
376  (je @done)
377  (mark-as-imm temp0)
378  @loop
379  (extract-fulltag arg_z temp0)
380  (cmpb ($ x8632::fulltag-cons) (% temp0.b)) ;nil is a cons on x8632, but we
381  (jne @bad)                                 ; checked for it already.
382  (%car arg_z temp1)
383  (%cdr arg_z arg_z)
384  (add ($ '1) (% imm0))                 ;shorter than lea (imm0 is eax)
385  (cmp-reg-to-nil arg_z)
386  (push (% temp1))
387  (jne @loop)
388  (mark-as-node temp0)
389  @done
390  ;; arg_y about to get clobbered; put function into xfn.
391  (movl (% function) (% xfn))           ;aka temp1
392  ;; imm0 (aka nargs) contains number of args just pushed
393  (test (% imm0) (% imm0))
394  (jne @pop)
395  @discard-and-go
396  (discard-reserved-frame)
397  (jmp @go)
398  @pop
399  (cmpl ($ '1) (% nargs))
400  (pop (% arg_z))
401  (je @discard-and-go)
402  (cmpl ($ '2) (% nargs))
403  (pop (% arg_y))
404  (je @discard-and-go)
405  @go
406  (pushl (@ (% :rcontext) x8632::tcr.save0))     ;return address
407  (movl (@ (% :rcontext) x8632::tcr.save1) (% next-method-context)) ;aka temp0
408  (movapd (% fpzero) (@ (% :rcontext) x8632::tcr.save0)) ;clear out spill area
409  (jmp (% xfn))                          ;aka temp1
410  @bad
411  (mark-as-node temp0)
412  (addl (% imm0) (% esp))
413  (movl (@ (% :rcontext) x8632::tcr.save1) (% arg_z)) ;saved args
414  (movapd (% fpzero) (@ (% :rcontext) x8632::tcr.save0)) ;clear out spill area
415  (movl ($ '#.$XNOSPREAD) (% arg_y))
416  (set-nargs 2)
417  (jmp-subprim .SPksignalerr))
418
419;;; The idea here is to call METHOD in the same stack frame in
420;;; which the lexpr was originally called.  The lexpr can't
421;;; have had any required arguments, %APPLY-LEXPR-TAIL-WISE
422;;; must have been tail-called, and the frame built on lexpr
423;;; entry must be in %rbp.
424(defx8632lapfunction %apply-lexpr-tail-wise ((method arg_y) (args arg_z))
425  (addl ($ x8632::node-size) (% esp))   ; discard extra return address
426  (movl (% method) (% xfn))             ;temp1
427  (movl (% args) (% esp))
428  (popl (% imm0))                       ;nargs
429  (movl (@ x8632::lisp-frame.return-address (% ebp)) (% temp0))
430  (movl (@ 0 (% ebp)) (% ebp))
431  (rcmpl (% imm0) ($ '2))
432  (jbe @pop-regs)
433  ;; More than 2 args; some must have been pushed by caller,
434  ;; so retain the reserved frame.
435  (pop (% arg_z))
436  (pop (% arg_y))
437  (jmp @popped)
438  @pop-regs
439  (rcmpl (% imm0) ($ '1))
440  (jb @discard)
441  (ja @pop2)
442  (pop (% arg_z))
443  (jmp @discard)
444  @pop2
445  (pop (% arg_z))
446  (pop (% arg_y))
447  @discard
448  (discard-reserved-frame)
449  @popped
450  (push (% temp0))                      ;return address
451  (movl (% xfn) (% temp0))              ;temp1 is also nargs
452  (movl (% imm0) (% nargs))
453  (jmp (% temp0)))
454
455(defun closure-function (fun)
456  (while (and (functionp fun) (not (compiled-function-p fun)))
457    (setq fun (%nth-immediate fun 0))
458    (when (vectorp fun)
459      (setq fun (svref fun 0))))
460  fun)
461
462;;; For use by (setf (apply ...) ...)
463;;; (apply+ f butlast last) = (apply f (append butlast (list last)))
464
465(defun apply+ (&lap function arg1 arg2 &rest other-args)
466  (x86-lap-function apply+ ()
467   (:arglist (function arg1 arg2 &rest other-args))
468   (check-nargs 3 nil)
469   (popl (@ (% :rcontext) x8632::tcr.save0))    ;save return address
470   ;; only two arg regs on x8632, so the caller will always push a frame
471   (movl (% arg_z) (% temp0))           ; last
472   (movl (% arg_y) (% arg_z))           ; butlast
473   (subl ($ '2) (% nargs))              ; remove count for butlast & last
474   (movd (% temp1) (% mm0))             ;save nargs (aka temp1) for later
475   ;; Do .SPspreadargz inline here
476   (xorl (%l temp1) (%l temp1))
477   (movl (% arg_z) (@ (% :rcontext) x8632::tcr.save1)) ; save in case of error
478   (cmp-reg-to-nil arg_z)
479   (je @done)
480   ;;(mark-as-imm temp1)
481   @loop
482   (extract-fulltag arg_z imm0)
483   (cmpb ($ x8632::fulltag-cons) (%b imm0))
484   (jne @bad)
485   (%car arg_z arg_y)
486   (%cdr arg_z arg_z)
487   (addl ($ '1) (%l temp1))
488   (cmp-reg-to-nil arg_z)   
489   (push (% arg_y))
490   (jne @loop)
491   @done
492   ;; nargs was at least 1 when we started spreading, and can't have gotten
493   ;; any smaller.
494   (movd (% mm0) (% arg_y))             ;nargs from before loop
495   (addl (% arg_y) (% temp1))           ;did I mention nargs is temp1?
496   (movl (% temp0) (% arg_z))
497   (pop (% arg_y))
498   (addl ($ '1) (% nargs))
499   (load-constant funcall temp0)
500   (pushl (@ (% :rcontext) x8632::tcr.save0))   ;return address
501   (movapd (% fpzero) (@ (% :rcontext) x8632::tcr.save0)) ;clear out spill area
502   (jmp-subprim .SPfuncall)
503   @bad                               ;error spreading list.
504   (add (% temp1) (% esp))            ;discard whatever's been pushed
505   (movl (@ (% :rcontext) x8632::tcr.save1) (% arg_z))
506   (movapd (% fpzero) (@ (% :rcontext) x8632::tcr.save0)) ;clear out spill area
507   (movl ($ '#.$XNOSPREAD) (% arg_y))
508   (set-nargs 2)
509   (jmp-subprim .SPksignalerr) ))
510
511
512
513;;; This needs to:
514;;; (b) call the .SPffcall subprimitive, which will discard the foreign stack frame
515;;;     allocated by WITH-VARIABLE-C-FRAME in %FF-CALL
516;;; (c) re-establish the same foreign stack frame and store the result regs
517;;;     (%eax/%xmm0) there (not really xmm0, but .SPffcall will pop the x87
518;;;     stack and put the value in there for us.
519
520(defx86lapfunction %do-ff-call ((frame arg_y) (entry arg_z))
521  (int ($ 3))
522  (pop (% ra0))
523  (movl (% ebp) (@  (% esp)))
524  (movl (% esp) (% ebp))
525  (movl (% ra0) (@ 4 (% ebp)))
526  (call-subprim .SPffcall)
527  (movd (@ (% :rcontext) x8664::tcr.foreign-sp) (% mm5))
528  (movd (% mm5) (@ (% frame)))
529  (movl (% frame) (@ (% :rcontext) x8664::tcr.foreign-sp))
530  (movl (% eax) (@ 4 (% frame)))
531  ;; .SPffcall will have popped the fp result from the x87 stack
532  ;; and stashed it in fp0.
533  (movq (% fp0) (@ 8 (% frame)))
534  (movl ($ nil) (% arg_z))
535  (restore-simple-frame)
536  (single-value-return))
537 
538(defun %ff-call (entry &rest specs-and-vals)
539  (declare (dynamic-extent specs-and-vals))
540  (let* ((len (length specs-and-vals))
541         (total-words 0))
542    (declare (fixnum len total-words))
543    (let* ((result-spec (or (car (last specs-and-vals)) :void))
544           (nargs (ash (the fixnum (1- len)) -1)))
545      (declare (fixnum nargs))
546      (ecase result-spec
547        ((:address :unsigned-doubleword :signed-doubleword
548                   :single-float :double-float
549                   :signed-fullword :unsigned-fullword
550                   :signed-halfword :unsigned-halfword
551                   :signed-byte :unsigned-byte
552                   :void)
553         (do* ((i 0 (1+ i))
554               (specs specs-and-vals (cddr specs))
555               (spec (car specs) (car specs)))
556              ((= i nargs))
557           (declare (fixnum i))
558           (case spec
559             (:registers
560              (error "don't know what to do with argspec ~s" spec))
561             ((:double-float :unsigned-doubleword :signed-doubleword)
562              (incf total-words 2))
563             ((:address :single-float
564                        :signed-fullword :unsigned-fullword
565                        :signed-halfword :unsigned-halfword
566                        :signed-byte :unsigned-byte)
567              (incf total-words))
568             (t (if (typep spec 'unsigned-byte)
569                  (incf total-words spec)
570                  (error "Invalid argument spec ~s" spec)))))
571         ;; It's necessary to ensure that the C frame is the youngest thing on
572         ;; the foreign stack here.
573         (with-macptrs ((argptr))
574           (with-variable-c-frame
575               total-words frame
576               (%setf-macptr-to-object argptr frame)
577               (let* ((offset 0))
578                 (do* ((i 0 (1+ i))
579                       (specs specs-and-vals (cddr specs))
580                       (spec (car specs) (car specs))
581                       (val (cadr specs) (cadr specs)))
582                      ((= i nargs))
583                   (declare (fixnum i))
584                   (case spec
585                     (:double-float
586                      (setf (%get-double-float argptr offset) val)
587                      (incf offset 8))
588                     (:single-float
589                      (setf (%get-single-float argptr offset) val)
590                      (incf offset 4))
591                     (:signed-doubleword
592                      (setf (%%get-signed-longlong argptr offset) val)
593                      (incf offset 8))
594                     (:unsigned-doubleword
595                      (setf (%%get-unsigned-longlong argptr offset) val)
596                      (incf offset 8))
597                     (:address
598                      (setf (%get-ptr argptr offset) val)
599                      (incf offset 4))
600                     ((:signed-fullword :signed-halfword :signed-byte)
601                      (setf (%get-signed-natural argptr offset) val)
602                      (incf offset 4))
603                     ((:unsigned-fullword :unsigned-halfword :unsigned-byte)
604                      (setf (%get-natural argptr offset) val)
605                      (incf offset 4))
606                     (t
607                      (let* ((p 0))
608                        (declare (fixnum p))
609                        (dotimes (i (the fixnum spec))
610                          (setf (%get-ptr argptr offset) (%get-ptr val p))
611                          (incf p 4)
612                          (incf offset 4))))))
613                 (%do-ff-call frame entry)
614                 (ecase result-spec
615                   (:void nil)
616                   (:address (%get-ptr argptr 4))
617                   (:unsigned-byte (%get-unsigned-byte argptr 4))
618                   (:signed-byte (%get-signed-byte argptr 4))
619                   (:unsigned-halfword (%get-unsigned-word argptr 4))
620                   (:signed-halfword (%get-signed-word argptr 4))
621                   (:unsigned-fullword (%get-natural argptr 4))
622                   (:signed-fullword (%get-signed-natural argptr 4))
623                   (:unsigned-doubleword (%%get-unsigned-longlong argptr 4))
624                   (:signed-doubleword (%%get-signed-longlong argptr 4))
625                   (:single-float (%get-single-float argptr 8))
626                   (:double-float (%get-double-float argptr 8)))))))))))
627
628;;; end of x86-def.lisp
Note: See TracBrowser for help on using the repository browser.