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

Last change on this file since 9192 was 9192, checked in by rme, 13 years ago

Remove %function-vector-to-function and %function-to-function-vector,
which don't do anything on x8632.

Use archmacros function-vector-to-function and function-to-function-vector
(no percent sign) in places they were called.

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