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

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

various stuff

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