source: branches/x8632-functions/level-0/X86/X8632/x8632-def.lisp @ 12349

Last change on this file since 12349 was 12349, checked in by rme, 11 years ago

Preliminary bootstrapping changes to support new function scheme on x8632.

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