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

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

New file.

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