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

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

Some easy lap functions updated. Lots more to convert.

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