Changeset 11590

Timestamp:

Jan 6, 2009, 6:00:06 PM (12 years ago)

Author:

rme

Message:

Additional x8632 FFI details involving structure return and callbacks.

DEFINE-CALLBACK: add hair to recognize when a hidden first argument
will need to be discarded on return. Try to deal with interactions
with the win32 _stdcall case, too. Pass info argument to
DEFINE-CALLBACK-FUNCTION that encodes the arg discard information.

DEFINE-CALLBACK-FUNCTION: pass said info argument to
MAKE-CALLBACK-TRAMPOLINE.

MAKE-CALLBACK-TRAMPOLINE: pack arg discarding information and the
callback index into the value that gets passed to .SPcallback via
the %eax register.

.SPcallback: decode this information, and handle discarding the
appropriate number of args on return.

Location:

trunk/source

Files:

• compiler/X86/X8632/x8632-backend.lisp (modified) (3 diffs)
• level-1/l1-callbacks.lisp (modified) (2 diffs)
• level-1/x86-callback-support.lisp (modified) (2 diffs)
• lib/macros.lisp (modified) (4 diffs)
• lisp-kernel/x86-spentry32.s (modified) (3 diffs)

trunk/source/compiler/X86/X8632/x8632-backend.lisp

@@ -285 +285 @@
 (pushnew *x8632-backend* *known-backends* :key #'backend-name)
 
-;;; FFI stuff.  Most operating systems use the same vanilla i386 ABI.
-;;; Darwin uses a variant that returns small (<= 64 bit) structures in
-;;; registers.  (There are some other Darwin exceptions too, but they
-;;; don't concern us here).
+;;; FFI stuff.  The vanilla i386 ABI always returns structures as a
+;;; hidden first argument.  Some systems (Darwin, FreeBSD) use a
+;;; variant that returns small (<= 64 bit) structures in registers.
 
 ;;; A returned structure is passed as a hidden first argument.
@@ -320 +319 @@
               (argforms result-form))
             (progn
-              ;; for Darwin
               (ecase (foreign-type-bits result-type)
                 (8 (setq result-type-spec :unsigned-byte
@@ -443 +441 @@
   (unless (eq return-type *void-foreign-type*)
     (if (typep return-type 'foreign-record-type)
-      ;; On non-Darwin systems, the result type would have been mapped
-      ;; to :VOID.  On Darwin, small (<= 64 bits) structs are returned
-      ;; by value.
+      ;; If the struct result is returned via a hidden argument, the
+      ;; return type would have been mapped to :VOID.  On some
+      ;; systems, small (<= 64 bits) structs are returned by value,
+      ;; which we arrange to retrieve here.
       (ecase (ensure-foreign-type-bits return-type)
         (8 `(setf (%get-unsigned-byte ,stack-ptr -8)

trunk/source/level-1/l1-callbacks.lisp

@@ -23 +23 @@
 
 ;;; (defcallback ...) expands into a call to this function.
-(defun define-callback-function (lisp-function  &optional doc-string (without-interrupts t) (info 0) &aux name trampoline)
+(defun define-callback-function (lisp-function  &optional doc-string (without-interrupts t) info &aux name trampoline)
   (unless (functionp lisp-function)
     (setq lisp-function (require-type lisp-function 'function)))
@@ -58 +58 @@
                        (unless (%svref %pascal-functions% i)
                          (return i)))))
-          (setq trampoline (make-callback-trampoline index (or info 0)))
+          (setq trampoline (make-callback-trampoline index info))
           (setf (%svref %pascal-functions% index)
                 (%cons-pfe trampoline info lisp-function name without-interrupts)))))

trunk/source/level-1/x86-callback-support.lisp

@@ -19 +19 @@
 
 #+x8664-target  
-(defun make-callback-trampoline (index &optional discard-stack-bytes)
-  (declare (ignore discard-stack-bytes))
+(defun make-callback-trampoline (index &optional info)
+  (declare (ignore info))
   (let* ((p (%allocate-callback-pointer 16))
          (addr #.(subprim-name->offset '.SPcallback)))
@@ -40 +40 @@
           
 #+x8632-target          
-(defun make-callback-trampoline (index &optional (discard-stack-bytes 0))
+(defun make-callback-trampoline (index &optional info)
   (let* ((p (%allocate-callback-pointer 12))
          (addr #.(subprim-name->offset '.SPcallback)))
+    ;; If the optional info parameter is supplied, it will contain
+    ;; some stuff in bits 23 through 31.
+    ;;
+    ;; If bit 23 is set, that indicates that the caller will pass a
+    ;; "hidden" argument which is a pointer to appropriate storage for
+    ;; holding a returned structure.  .SPcallback will have to discard
+    ;; this extra argument upon return.
+    ;;
+    ;; The high 8 bits denote the number of words that .SPcallback
+    ;; will have to discard upon return (used for _stdcall on
+    ;; Windows).  Bit 23 won't be set in this case: we will have
+    ;; already added in the extra word to discard if that's necessary.
+    ;; 
+    ;; These bits are be packed into the value that .SPcallback
+    ;; receives in %eax.  Bits 0 through 22 are the callback index.
+    (if info
+      (setf (ldb (byte 23 0) info) index)
+      (setq info index))
     (setf (%get-unsigned-byte p 0) #xb8 ; movl $n,%eax
-          (%get-unsigned-byte p 1) (ldb (byte 8 0) index)
-          (%get-unsigned-byte p 2) (ldb (byte 8 8) index)
-          (%get-unsigned-byte p 3) (ldb (byte 8 16) index)
-          (%get-unsigned-byte p 4) (ldb (byte 8 0) (ash (or discard-stack-bytes 0) (- x8632::word-shift)))
+          (%get-unsigned-byte p 1) (ldb (byte 8 0) info)
+          (%get-unsigned-byte p 2) (ldb (byte 8 8) info)
+          (%get-unsigned-byte p 3) (ldb (byte 8 16) info)
+          (%get-unsigned-byte p 4) (ldb (byte 8 24) info)
           (%get-unsigned-byte p 5) #xff  ; jmp *
           (%get-unsigned-byte p 6) #x24

trunk/source/lib/macros.lisp

@@ -2541 +2541 @@
          (result-type-spec :void)
          (args args)
-         (discard-stack-args nil)
+         (discard-stack-args nil)       ;only meaningful on win32
+         (discard-hidden-arg nil)       ;only meaningful on x8632
+         (info nil)
          (woi nil)
          (need-struct-arg)
@@ -2551 +2553 @@
              (rtype (ignore-errors (parse-foreign-type spec))))
         (setq need-struct-arg (typep rtype 'foreign-record-type))
+        (when need-struct-arg
+          (setq discard-hidden-arg
+                (funcall (ftd-ff-call-struct-return-by-implicit-arg-function
+                          *target-ftd*) rtype)))
         (if rtype
           (setq result-type-spec spec args (butlast args))))
@@ -2571 +2577 @@
           (funcall (ftd-callback-bindings-function *target-ftd*)
                    stack-ptr fp-args-ptr (arg-names) (arg-specs) result-type-spec struct-return-arg-name)
-        (unless num-arg-bytes (setq num-arg-bytes 0))
+        ;; x8632 hair
+        (when discard-hidden-arg
+          (if discard-stack-args
+            ;; We already have to discard some number of args, so just
+            ;; discard the extra hidden arg while we're at it.
+            (incf num-arg-bytes 4)
+            ;; Otherwise, indicate that we'll need to discard the
+            ;; hidden arg.
+            (setq info (ash 1 23))))
+        (when discard-stack-args
+          (setq info 0)
+          ;; put number of words to discard in high-order byte
+          (setf (ldb (byte 8 24) info)
+                (ash num-arg-bytes (- target::word-shift))))
         (multiple-value-bind (body decls doc) (parse-body body env t)
           `(progn
@@ -2599 +2618 @@
                 ,doc
               ,woi
-              ,(if discard-stack-args num-arg-bytes 0))))))))
+              ,info)))))))
 
 

trunk/source/lisp-kernel/x86-spentry32.s

@@ -4252 +4252 @@
         /* arg word 0 at 8(%ebp), word 1 at 12(%ebp), etc. */
 
+        /* %eax is passed to us via the callback trampoline.
+           bits 0-22: callback index
+           bit 23: flag, set if we need to discard hidden arg on return
+                   (ignored when upper 8 bits are non-zero)
+           bits 24-31: arg words to discard on return (_stdcall for win32) */
+        
         /* Reserve some space for results, relative to the
            current %ebp.  We may need quite a bit of it. */
-        __(subl $24,%esp)
+        __(subl $20,%esp)
         __(movl $0,-16(%ebp)) /* No FP result */
+        __(btl $23,%eax)      /* set CF if we need to discard hidden arg */
+        __(pushfl)            /* and save for later */
         __(movl %eax,%ecx)    /* extract args-discard count */
         __(shrl $24,%ecx)
-        __(andl $0x00ffffff,%eax)
+        __(andl $0x007fffff,%eax) /* callback index */
         __(movl %ecx,-12(%ebp))
         /* If the C stack is 16-byte aligned by convention,
@@ -4328 +4336 @@
         __(movl -8(%ebp),%eax)
         __(movl -4(%ebp),%edx)
-        __(leave)
         __ifdef([WIN_32])
          __(testl %ecx,%ecx)
          __(jne local_label(winapi_return))
-         __(repret)
-        __else
-         __(ret)
-        __endif
+        __endif
+        __(popfl)       /* flags from bt way back when */
+        __(jc local_label(discard_first_arg))
+        __(leave)
+        __(ret)
 1:      __(jne 2f)
         /* single float return in x87 */
         __(flds -8(%ebp))
-        __(leave)
         __ifdef([WIN_32])
          __(testl %ecx,%ecx)
          __(jne local_label(winapi_return))
-         __(repret)
-        __else
-         __(ret)
         __endif
+        __(leave)
+        __(ret)
 2:      /* double-float return in x87 */
         __(fldl -8(%ebp))
-        __(leave)
         __ifdef([WIN_32])
          __(testl %ecx,%ecx)
          __(jne local_label(winapi_return))
-         __(repret)
-        __else
-         __(ret)
         __endif
+        __(leave)
+        __(ret)
         __ifdef([WIN_32])
-local_label(winapi_return):             
+local_label(winapi_return):
+          __(leave)
          /* %ecx is non-zero and contains count of arg words to pop */
           __(popl -4(%esp,%ecx,4))
@@ -4364 +4369 @@
           __(ret)
         __endif
+local_label(discard_first_arg):
+        __(leave)
+        __(ret $4)
 _endsubp(callback)