Index: /branches/ia32/level-0/X86/X8632/x8632-def.lisp
===================================================================
--- /branches/ia32/level-0/X86/X8632/x8632-def.lisp	(revision 7361)
+++ /branches/ia32/level-0/X86/X8632/x8632-def.lisp	(revision 7361)
@@ -0,0 +1,649 @@
+;;; -*- Mode: Lisp; Package: CCL -*-
+;;;
+;;;   Copyright (C) 2006, Clozure Associates and contributors
+;;;   This file is part of OpenMCL.  
+;;;
+;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
+;;;   License , known as the LLGPL and distributed with OpenMCL as the
+;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
+;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
+;;;   conflict, the preamble takes precedence.  
+;;;
+;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
+;;;
+;;;   The LLGPL is also available online at
+;;;   http://opensource.franz.com/preamble.html
+
+(in-package "CCL")
+
+(defx86lapfunction %function-vector-to-function ((arg arg_z))
+  (single-value-return))
+
+(defx86lapfunction %function-to-function-vector  ((arg arg_z))
+  (single-value-return))
+
+(defx86lapfunction %function-code-words ((fun arg_z))
+  (trap-unless-typecode= fun x8632::subtag-function)
+  (xorl (% imm0) (% imm0))
+  (movw (@ x8632::misc-data-offset (% fun)) (% imm0.w))
+  (box-fixnum imm0 arg_z)
+  (single-value-return))
+
+(defx86lapfunction %nth-immediate ((fun arg_y) (n arg_z))
+  (trap-unless-typecode= fun x8632::subtag-function)
+  (xorl (% imm0) (% imm0))
+  (movw (@ x8632::misc-data-offset (% fun)) (% imm0.w))
+  (lea (@ (% n) (% imm0) 4) (% imm0))
+  (movl (@ x8632::misc-data-offset (% fun) (% imm0)) (% arg_z))
+  (single-value-return))
+
+(defx86lapfunction %set-nth-immediate ((fun 4) #|(ra 0)|# (n arg_y) (new arg_z))
+  (movl (@ fun (% esp)) (% temp0))
+  (trap-unless-typecode= temp0 x8632::subtag-function)
+  (movl (@ x8632::misc-data-offset (% temp0)) (% imm0))
+  (lea (@ (% n) (% imm0) 4) (% arg_y))
+  ;; expects gvector in temp0
+  (jmp-subprim .SPgvset))
+
+(defx86lapfunction %function-code-byte ((fun arg_y) (pc arg_z))
+  (unbox-fixnum pc imm0)
+  (movzbl (@ (% fun) (% imm0)) (% imm0))
+  (box-fixnum imm0 arg_z)
+  (single-value-return))
+
+;;; ----
+
+
+;;; Returns 3 values: mask of registers used in the function, stack location
+;;; from which they'd be restored, relative PC at which they're saved. If
+;;; the mask is 0, the values NIL NIL NIL are returned. If either the stack
+;;; location or relative PC is #xff, both of those values will be returned
+;;; as NIL.
+(defx86lapfunction %function-register-usage ((f arg_z))
+  (check-nargs 1)
+  (trap-unless-fulltag= f x8664::fulltag-function)
+  (movzbl (@ -1 (% f)) (% imm0.l))
+  (shll ($ 8) (% imm0.l))
+  (box-fixnum imm0 arg_x)
+  (movq (% rsp) (% temp0))
+  (set-nargs 3)
+  (je @no-regs)
+  (movzbl (@ -2 (% f)) (% imm0.l))
+  (movzbl (@ -3 (% f)) (% imm1.l))
+  (cmpb ($ #xff) (% imm0.b))
+  (je @unencodable)
+  (cmpb ($ #xff) (% imm1.b))
+  (je @unencodable)
+  (box-fixnum imm0 arg_y)
+  (box-fixnum imm1 arg_z)
+  (push (% arg_x))
+  (push (% arg_y))
+  (push (% arg_z))
+  (jmp-subprim .SPvalues)
+  @unencodable
+  (push (% arg_x))
+  (pushq ($ nil))
+  (pushq ($ nil))
+  (jmp-subprim .SPvalues)
+  @no-regs
+  (pushq ($ nil))
+  (pushq ($ nil))
+  (pushq ($ nil))
+  (jmp-subprim .SPvalues))
+  
+        
+
+(defx86lapfunction %make-code-executable ((codev arg_z))
+  (single-value-return))
+
+         
+
+(defx86lapfunction %get-kernel-global-from-offset ((offset arg_z))
+  (check-nargs 1)
+  (unbox-fixnum offset imm0)
+  (movq (@ target::nil-value (% imm0)) (% arg_z))
+  (single-value-return))
+
+(defx86lapfunction %set-kernel-global-from-offset ((offset arg_y) (new-value arg_z))
+  (check-nargs 2)
+  (unbox-fixnum offset imm0)
+  (movq (% arg_z) (@ target::nil-value (% imm0)))
+  (single-value-return))
+
+
+(defx86lapfunction %get-kernel-global-ptr-from-offset ((offset arg_y)
+						       (ptr arg_z))
+  (check-nargs 2)
+  (unbox-fixnum offset imm0)
+  (movq (@ target::nil-value (% imm0)) (% imm0))
+  (movq (% imm0) (@ x8664::macptr.address (% ptr)))
+  (single-value-return))
+
+
+
+
+(defx86lapfunction %fixnum-ref ((fixnum arg_y) #| &optional |# (offset arg_z))
+  (:arglist (fixnum &optional offset))
+  (check-nargs 1 2)
+  (cmpw ($ x8664::fixnumone) (% nargs))
+  (jne @2-args)
+  (movq (% offset) (% fixnum))
+  (xorl (%l offset) (%l offset))
+  @2-args
+  (unbox-fixnum offset imm0)
+  (movq (@ (% fixnum) (% imm0)) (% arg_z))
+  (single-value-return))
+
+(defx86lapfunction %fixnum-ref-natural ((fixnum arg_y) #| &optional |# (offset arg_z))
+  (:arglist (fixnum &optional offset))
+  (check-nargs 1 2)
+  (cmpw ($ x8664::fixnumone) (% nargs))
+  (jne @2-args)
+  (movq (% offset) (% fixnum))
+  (xorl (%l offset) (%l offset))
+  @2-args
+  (unbox-fixnum offset imm0)
+  (movq (@ (% fixnum) (% imm0)) (% imm0))
+  (jmp-subprim .SPmakeu64))
+
+(defx86lapfunction %fixnum-set ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z))
+  (:arglist (fixnum offset &optional newval))
+  (check-nargs 2 3)
+  (cmpw ($ '2) (% nargs))
+  (jne @3-args)
+  (movq (% offset) (% fixnum))
+  (xorl (%l offset) (%l offset))
+  @3-args
+  (unbox-fixnum offset imm0)
+  (movq (% new-value) (@ (% fixnum) (% imm0)))
+  (movq (% new-value) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction %fixnum-set-natural ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z))
+  (:arglist (fixnum offset &optional newval))
+  (check-nargs 2 3)
+  (save-simple-frame)
+  (cmpw ($ '2) (% nargs))
+  (jne @3-args)
+  (movq (% offset) (% fixnum))
+  (xorl (%l offset) (%l offset))
+  @3-args
+  (call-subprim .SPgetu64)
+  (unbox-fixnum offset imm1)
+  (movq (% imm0) (@ (% fixnum) (% imm1)))
+  (restore-simple-frame)
+  (single-value-return))
+
+
+(defx86lapfunction %current-frame-ptr ()
+  (check-nargs 0)
+  (movq (% rbp) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction %current-tsp ()
+  (check-nargs 0)
+  (movq (@ (% :rcontext) x8664::tcr.save-tsp) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction %%frame-backlink ((p arg_z))
+  (check-nargs 1)
+  (movq (@ (% arg_z)) (% arg_z))
+  (single-value-return))
+
+;;; Look for "lea -nnnn(%rip),%fn" AT the tra; if that's present, use
+;;; the dispacement -nnnn to find the function.  The end of the
+;;; encoded displacement is
+;;; x8664::recover-fn-from-rip-disp-offset (= 7) bytes from the tra.
+(defx86lapfunction %return-address-function ((r arg_z))
+  (extract-lisptag r imm0)
+  (cmpb ($ x8664::tag-tra) (% imm0.b))
+  (jne @fail)
+  (cmpw ($ x8664::recover-fn-from-rip-word0) (@ (% r)))
+  (jne @fail)
+  (cmpb ($ x8664::recover-fn-from-rip-byte2) (@ 2 (% r)))
+  (movslq (@ x8664::recover-fn-from-rip-disp-offset (% r)) (% imm0))
+  (jne @fail)
+  (lea (@ x8664::recover-fn-from-rip-length (% imm0) (% r)) (% arg_z))
+  (single-value-return)
+  @fail
+  (movl ($ x8664::nil-value) (% arg_z.l))
+  (single-value-return))
+
+(defx86lapfunction %return-address-offset ((r arg_z))
+  (extract-lisptag r imm0)
+  (cmpb ($ x8664::tag-tra) (% imm0.b))
+  (jne @fail)
+  (cmpw ($ x8664::recover-fn-from-rip-word0) (@ (% r)))
+  (jne @fail)
+  (cmpb ($ x8664::recover-fn-from-rip-byte2) (@ 2 (% r)))
+  (movslq (@ x8664::recover-fn-from-rip-disp-offset (% r)) (% imm0))
+  (jne @fail)
+  (negq (% imm0))
+  (leaq (@ (- (ash x8664::recover-fn-from-rip-length x8664::fixnumshift)) (% imm0) 8) (% arg_z))
+  (single-value-return)
+  @fail
+  (movl ($ x8664::nil-value) (% arg_z.l))
+  (single-value-return))
+
+;;; It's always been the case that the function associated with a
+;;; frame pointer is the caller of the function that "uses" that frame.
+(defun %cfp-lfun (p)
+  (let* ((ra (%fixnum-ref p x8664::lisp-frame.return-address)))
+    (if (eq ra (%get-kernel-global ret1valaddr))
+      (setq ra (%fixnum-ref p x8664::lisp-frame.xtra)))
+    (values (%return-address-function ra) (%return-address-offset ra))))
+
+
+
+(defx86lapfunction %uvector-data-fixnum ((uv arg_z))
+  (check-nargs 1)
+  (trap-unless-fulltag= arg_z x8664::fulltag-misc)
+  (addq ($ x8664::misc-data-offset) (% arg_z))
+  (single-value-return))
+
+(defx86lapfunction %catch-top ((tcr arg_z))
+  (check-nargs 1)
+  (movl ($ x8664::nil-value) (%l arg_y))
+  (movq (@ (% :rcontext) x8664::tcr.catch-top) (% arg_z))
+  (testb (%b arg_z) (%b arg_z))
+  (cmoveq (% arg_y) (% arg_z))
+  (single-value-return))
+
+(defx86lapfunction %catch-tsp ((catch arg_z))
+  (check-nargs 1)
+  (lea (@  (- (+ target::fulltag-misc
+                                 (ash 1 (1+ target::word-shift)))) (% arg_z))
+       (% arg_z))
+  (single-value-return))
+
+
+
+;;; Same as %address-of, but doesn't cons any bignums
+;;; It also left shift fixnums just like everything else.
+(defx86lapfunction %fixnum-address-of ((x arg_z))
+  (check-nargs 1)
+  (box-fixnum x arg_z)
+  (single-value-return))
+
+(defx86lapfunction %save-standard-binding-list ((bindings arg_z))
+  (movq (@ (% :rcontext) x8664::tcr.vs-area) (% imm0))
+  (movq (@ x8664::area.high (% imm0)) (% imm1))
+  (subq ($ x8664::node-size) (% imm1))
+  (movq (% bindings) (@ (% imm1)))
+  (single-value-return))
+
+(defx86lapfunction %saved-bindings-address ()
+  (movq (@ (% :rcontext) x8664::tcr.vs-area) (% imm0))
+  (movq (@ x8664::area.high (% imm0)) (% imm1))
+  (lea (@ (- x8664::node-size) (% imm1)) (% arg_z))
+  (single-value-return))
+
+(defx86lapfunction %get-object ((macptr arg_y) (offset arg_z))
+  (check-nargs 2)
+  (trap-unless-typecode= macptr x8664::subtag-macptr)
+  (macptr-ptr macptr imm0)
+  (trap-unless-lisptag= offset target::tag-fixnum imm1)
+  (unbox-fixnum offset imm1)
+  (movq (@ (% imm0) (% imm1)) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction %set-object ((macptr arg_x) (offset arg_y) (value arg_z))
+  (check-nargs 3)
+  (trap-unless-typecode= macptr target::subtag-macptr)
+  (macptr-ptr macptr imm0)
+  (trap-unless-lisptag= offset target::tag-fixnum imm1)
+  (unbox-fixnum offset imm1)
+  (movq (% arg_z) (@ (% imm0) (% imm1)))
+  (single-value-return))
+
+(defx86lapfunction %apply-lexpr-with-method-context ((magic arg_x)
+                                                     (function arg_y)
+                                                     (args arg_z))
+  ;; Somebody's called (or tail-called) us.
+  ;; Put magic arg in x8664::next-method-context (= x8664::temp0).
+  ;; Put function in x8664::xfn until we're ready to jump to it.
+  ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z,
+  ;;   but preserves x866::xfn/x8664::next-method-context.
+  ;; Jump to the function in x8664::xfn.
+  (popq (% ra0))
+  (movq (% magic) (% next-method-context))
+  (movq (% function) (% xfn))
+  (set-nargs 0)
+  (movq (@ (% args)) (% imm0))          ;lexpr-count
+  (movw (% imm0.w) (% nargs))
+  (leaq (@ x8664::node-size (% arg_z) (% imm0)) (% imm1))
+  (subw ($ '3) (% imm0.w))
+  (jbe @reg-only)
+  ;; Some args will be pushed; reserve a frame
+  (pushq ($ x8664::reserved-frame-marker))
+  (pushq ($ x8664::reserved-frame-marker))
+  @pushloop
+  (pushq (@ (- x8664::node-size) (% imm1)))
+  (subq ($ x8664::node-size) (% imm1))
+  (subq ($ x8664::node-size) (% imm0))
+  (jne @pushloop)
+  @three
+  (movq (@ (* x8664::node-size 3) (% arg_z)) (% arg_x))
+  @two
+  (movq (@ (* x8664::node-size 2) (% arg_z)) (% arg_y))
+  @one
+  (movq (@ (* x8664::node-size 1) (% arg_z)) (% arg_z))
+  (jmp @go)
+  @reg-only
+  (testw (% nargs) (% nargs))
+  (je @go)
+  (rcmpw (% nargs) ($ '2))
+  (je @two)
+  (jb @one)
+  (jmp @three)
+  @go
+  (push (% ra0))
+  (jmp (% xfn)))
+
+(defx86lapfunction %apply-with-method-context ((magic arg_x)
+                                               (function arg_y)
+                                               (args arg_z))
+  ;; Somebody's called (or tail-called) us.
+  ;; Put magic arg in x8664::next-method-context (= x8664::temp0).
+  ;; Put function in x8664::xfn (= x8664::temp1).
+  ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z,
+  ;;   but preserves x8664::xfn/x8664::next-method-context.
+  ;; Jump to the function in x8664::xfn.
+  (pop (% ra0))  
+  (movq (% magic) (% x8664::next-method-context))
+  (movq (% function) (% x8664::xfn))
+  (movq (% args) (% arg_y))             ; in case of error
+  (set-nargs 0)
+  (xorl (% imm0.l) (% imm0.l))
+  (push (% imm0))                       ; reserve frame (might discard
+  (push (% imm0))                       ; it if nothing is passed on stack.)
+  (cmp-reg-to-nil arg_z)
+  (je @done)
+  @loop
+  (extract-fulltag arg_z imm1)
+  (cmpb ($ x8664::fulltag-cons) (%b imm1))
+  (jne @bad)
+  (%car arg_z arg_x)
+  (%cdr arg_z arg_z)
+  (lea (@ x8664::node-size (% imm0)) (% imm0))
+  (cmp-reg-to-nil arg_z)
+  (push (% arg_x))
+  (jne @loop)
+  @done
+  (addw (% imm0.w) (% nargs))
+  (jne @pop)
+  @discard-and-go
+  (discard-reserved-frame)
+  (jmp @go)
+  @pop
+  (cmpw ($ '1) (% nargs))
+  (pop (% arg_z))
+  (je @discard-and-go)
+  (cmpw ($ '2) (% nargs))
+  (pop (% arg_y))
+  (je @discard-and-go)
+  (cmpw ($ '3) (% nargs))
+  (pop (% arg_x))
+  (je @discard-and-go)
+  @go
+  (push (% ra0))
+  (jmp (% xfn))
+  @bad
+  (addq (% imm0) (% rsp))
+  (movq (% arg_y) (% arg_z))
+  (movq ($ (ash $XNOSPREAD x8664::fixnumshift)) (% arg_y))
+  (set-nargs 2)
+  (jmp-subprim .SPksignalerr))
+
+
+;;; The idea here is to call METHOD in the same stack frame in
+;;; which the lexpr was originally called.  The lexpr can't
+;;; have had any required arguments, %APPLY-LEXPR-TAIL-WISE
+;;; must have been tail-called, and the frame built on lexpr
+;;; entry must be in %rbp.
+(defx86lapfunction %apply-lexpr-tail-wise ((method arg_y) (args arg_z))
+  (addq ($ x8664::node-size) (% rsp))   ; discard extra return address
+  (movq (% method) (% xfn))
+  (movq (% args) (% rsp))
+  (pop (%q nargs))
+  (movq (@ x8664::lisp-frame.return-address (% rbp)) (% ra0))
+  (movq (@ 0 (% rbp)) (% rbp))
+  (rcmpw (% nargs) ($ '3))
+  (jbe @pop-regs)
+  ;; More than 3 args; some must have been pushed by caller,
+  ;; so retain the reserved frame.
+  (pop (% arg_z))
+  (pop (% arg_y))
+  (pop (% arg_x))
+  (jmp @popped)
+  @pop-regs
+  (je @pop3)
+  (rcmpw (% nargs) ($ '1))
+  (jb @discard)
+  (ja @pop2)
+  (pop (% arg_z))
+  (jmp @discard)
+  @pop3
+  (pop (% arg_z))
+  (pop (% arg_y))
+  (pop (% arg_x))
+  (jmp @discard)
+  @pop2
+  (pop (% arg_z))
+  (pop (% arg_y))
+  @discard
+  (discard-reserved-frame)
+  @popped
+  (push (% ra0))
+  (jmp (% xfn)))
+
+
+
+
+;;; For use by (setf (apply ...) ...)
+;;; (apply+ f butlast last) = (apply f (append butlast (list last)))
+
+(defun apply+ (&lap function arg1 arg2 &rest other-args)
+  (x86-lap-function apply+ ()
+   (:arglist (function arg1 arg2 &rest other-args))
+   (check-nargs 3 nil)
+   (cmpw ($ '3) (% nargs))
+   (pop (% ra0))
+   (ja @no-frame)
+   (pushq ($ x8664::reserved-frame-marker))
+   (pushq ($ x8664::reserved-frame-marker))
+@no-frame         
+   (push (% arg_x))
+   (movq (% arg_z) (% temp0))           ; last
+   (movq (% arg_y) (% arg_z))           ; butlast
+   (subw ($ '2) (% nargs))              ; remove count for butlast & last
+   ;; Do .SPspreadargz inline here
+   (xorl (%l imm0) (%l imm0))
+   (movq (% arg_z) (% arg_y))           ; save in case of error
+   (cmp-reg-to-nil arg_z)
+   (je @done)
+   @loop
+   (extract-fulltag arg_z imm1)
+   (cmpb ($ x8664::fulltag-cons) (%b imm1))
+   (jne @bad)
+   (%car arg_z arg_x)
+   (%cdr arg_z arg_z)
+   (addl ($ '1) (%l imm0))
+   (cmp-reg-to-nil arg_z)   
+   (push (% arg_x))
+   (jne @loop)
+   @done
+   ;; nargs was at least 1 when we started spreading, and can't have gotten
+   ;; any smaller. 
+   (addw (%w imm0) (% nargs))
+   (movq (% temp0) (% arg_z))
+   (pop (% arg_y))
+   (pop (% arg_x))
+   (addw ($ '1) (% nargs))
+   (cmpw ($ '3) (% nargs))
+   (jne @no-discard)
+   (discard-reserved-frame)
+   @no-discard
+   (load-constant funcall temp0)
+   (push (% ra0))
+   (jmp-subprim .SPfuncall)
+   @bad                                 ; error spreading list.
+   (add (% imm0) (% rsp))               ; discard whatever's been pushed
+   (movq (% arg_y) (% arg_z))
+   (movl ($ '#.$XNOSPREAD) (%l arg_y))
+   (set-nargs 2)
+   (jmp-subprim .SPksignalerr) ))
+
+
+
+;;; This needs to:
+;;; (a) load FP arg regs from the FP-REGS argument
+;;; (b) call the .SPffcall subprimitive, which will discard the foreign stack frame
+;;;     allocated by WITH-VARIABLE-C-FRAME in %FF-CALL
+;;; (c) re-establish the same foreign stack frame and store the result regs
+;;;     (%rax/%xmm0) there
+(defx86lapfunction %do-ff-call ((nfp 0) (frame arg_x) (fp-regs arg_y) (entry arg_z))
+  (popq (% ra0))
+  (popq (% rax))
+  (movq (% rbp) (@  (% rsp)))
+  (movq (% rsp) (% rbp))
+  (movq (% ra0) (@ 8 (% rbp)))
+  (macptr-ptr fp-regs temp0)
+  (sarq ($ x8664::fixnumshift) (% rax))
+  (movq (@ (% temp0)) (% fp0))
+  (movq (@ 8 (% temp0)) (% fp1))
+  (movq (@ 16 (% temp0)) (% fp2))
+  (movq (@ 24 (% temp0)) (% fp3))
+  (movq (@ 32 (% temp0)) (% fp4))
+  (movq (@ 40 (% temp0)) (% fp5))
+  (movq (@ 48 (% temp0)) (% fp6))
+  (movq (@ 56 (% temp0)) (% fp7))
+  (call-subprim .SPffcall)
+  (movq (@ (% :rcontext) x8664::tcr.foreign-sp) (% mm5))
+  (movq (% mm5) (@ (% frame)))
+  (movq (% frame) (@ (% :rcontext) x8664::tcr.foreign-sp))
+  (movq (% rax) (@ 8 (% frame)))
+  (movq (% fp0) (@ 16 (% frame)))
+  (movl ($ nil) (%l arg_z))
+  (restore-simple-frame)
+  (single-value-return))
+  
+
+(defun %ff-call (entry &rest specs-and-vals)
+  (declare (dynamic-extent specs-and-vals))
+  (let* ((len (length specs-and-vals))
+         (total-words 0))
+    (declare (fixnum len total-words))
+    (let* ((result-spec (or (car (last specs-and-vals)) :void))
+           (nargs (ash (the fixnum (1- len)) -1))
+           (n-fp-args 0))
+      (declare (fixnum nargs n-fp-args))
+      (ecase result-spec
+        ((:address :unsigned-doubleword :signed-doubleword
+                   :single-float :double-float
+                   :signed-fullword :unsigned-fullword
+                   :signed-halfword :unsigned-halfword
+                   :signed-byte :unsigned-byte
+                   :void)
+         (do* ((i 0 (1+ i))
+               (specs specs-and-vals (cddr specs))
+               (spec (car specs) (car specs)))
+              ((= i nargs))
+           (declare (fixnum i))
+           (case spec
+             ((:address :unsigned-doubleword :signed-doubleword
+                        :single-float :double-float
+                        :signed-fullword :unsigned-fullword
+                        :signed-halfword :unsigned-halfword
+                        :signed-byte :unsigned-byte)
+              (incf total-words))
+             (t (if (typep spec 'unsigned-byte)
+                  (incf total-words spec)
+                  (error "unknown arg spec ~s" spec)))))
+         ;; It's necessary to ensure that the C frame is the youngest thing on
+         ;; the foreign stack here.
+         (%stack-block ((fp-args (* 8 8)))
+           (with-macptrs ((argptr))
+             (with-variable-c-frame
+                 total-words frame
+                 (%setf-macptr-to-object argptr frame)
+                 (let* ((gpr-offset 16)
+                        (other-offset (+ gpr-offset (* 6 8))))
+                   (declare (fixnum gpr-offset other-offset))
+                   (do* ((i 0 (1+ i))
+                         (ngpr-args 0)
+                         (specs specs-and-vals (cddr specs))
+                         (spec (car specs) (car specs))
+                         (val (cadr specs) (cadr specs)))
+                        ((= i nargs))
+                     (declare (fixnum i))
+                     (case spec
+                       (:address
+                        (incf ngpr-args)
+                        (cond ((<= ngpr-args 6)
+                               (setf (%get-ptr argptr gpr-offset) val)
+                               (incf gpr-offset 8))
+                              (t
+                               (setf (%get-ptr argptr other-offset) val)
+                               (incf other-offset 8))))
+                       ((:signed-doubleword :signed-fullword :signed-halfword
+                                            :signed-byte)
+                        (incf ngpr-args)
+                        (cond ((<= ngpr-args 6)
+                               (setf (%%get-signed-longlong argptr gpr-offset) val)
+                               (incf gpr-offset 8))
+                              (t
+                               (setf (%%get-signed-longlong argptr other-offset) val)
+                               (incf other-offset 8))))
+                       ((:unsigned-doubleword :unsigned-fullword :unsigned-halfword
+                                              :unsigned-byte)
+                        (incf ngpr-args)
+                        (cond ((<= ngpr-args 6)
+                               (setf (%%get-unsigned-longlong argptr gpr-offset) val)
+                               (incf gpr-offset 8))
+                              (t
+                               (setf (%%get-unsigned-longlong argptr other-offset) val)
+                               (incf other-offset 8))))
+                       (:double-float
+                        (cond ((< n-fp-args 8)
+                               (setf (%get-double-float fp-args (* n-fp-args 8)) val)
+                               (incf n-fp-args))
+                              (t
+                               (setf (%get-double-float argptr other-offset) val)
+                               (incf other-offset 8))))
+                       (:single-float
+                        (cond ((< n-fp-args 8)
+                               (setf (%get-single-float fp-args (* n-fp-args 8))
+                                     val)
+                               (incf n-fp-args))
+                              (t 
+                               (setf (%get-single-float argptr other-offset) val)
+                               (incf other-offset 8))))
+                       (t
+                        (let* ((p 0))
+                          (declare (fixnum p))
+                          (dotimes (i (the fixnum spec))
+                            (setf (%get-ptr argptr other-offset) (%get-ptr val p))
+                            (incf p 8)
+                            (incf other-offset 8)))))))
+                 (%do-ff-call (min n-fp-args 8) frame fp-args entry)
+                 (ecase result-spec
+                   (:void nil)
+                   (:address (%get-ptr argptr 8))
+                   (:unsigned-byte (%get-unsigned-byte argptr 8))
+                   (:signed-byte (%get-signed-byte argptr 8))
+                   (:unsigned-halfword (%get-unsigned-word argptr 8))
+                   (:signed-halfword (%get-signed-word argptr 8))
+                   (:unsigned-fullword (%get-unsigned-long argptr 8))
+                   (:signed-fullword (%get-signed-long argptr 8))
+                   (:unsigned-doubleword (%get-natural argptr 8))
+                   (:signed-doubleword (%get-signed-natural argptr 8))
+                   (:single-float (%get-single-float argptr 16))
+                   (:double-float (%get-double-float argptr 16)))))))))))
+                                 
+
+;;; end of x86-def.lisp