source: trunk/source/level-0/X86/X8632/x8632-def.lisp @ 10489

Last change on this file since 10489 was 10489, checked in by gb, 11 years ago

%APPLY-WITH-METHOD-CONTEXT: try to fix register usage (still don't
have enough registers, and I wound up using the last slot in the tcr
spill area and doing push/ret, which may be hard on the call-return
tracking stuff.)

This seems to fix at least the simple case in ticket:325, and
a few other simple cases seem to work.

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