Changeset 12591

Timestamp:

Aug 16, 2009, 2:26:07 PM (15 years ago)

Author:

Gary Byers

Message:

In DEFCALLBACK-BODY: don't use a temporary for the result (except
in the struct-return case, where it's hard to avoid.) If the callback
uses an ERROR-RETURN mechanism, do the foreign-result-return inside
the body of the handler (so that the foreign result doesn't have to
be boxed during unwinding.)

Both of these changes are intended to reduce incidental consing in
callbacks.

File:

• trunk/source/lib/macros.lisp (modified) (3 diffs)

trunk/source/lib/macros.lisp

@@ -2665 +2665 @@
   (destructuring-bind (stack-ptr fp-args-ptr lets rlets inits dynamic-extent-decls other-decls body return-type struct-return-arg error-return error-delta) args
     (declare (ignorable dynamic-extent-decls))
-    (let* ((result (gensym))
-           (condition-name (if (atom error-return) 'error (car error-return)))
+    (let* ((condition-name (if (atom error-return) 'error (car error-return)))
            (error-return-function (if (atom error-return) error-return (cadr error-return)))
+           (result (if struct-return-arg (gensym)))
            (body
             `(rlet ,rlets
@@ -2674 +2674 @@
                 ,@other-decls
                 ,@inits
-                (let ((,result (progn ,@body)))
-                  (declare (ignorable ,result)
-                           (dynamic-extent ,result))
-
-                  ,(funcall (ftd-callback-return-value-function *target-ftd*)
-                            stack-ptr
-                            fp-args-ptr
-                            result
-                            return-type
-                            struct-return-arg)
-                  nil)))))
+                ,(if result
+                     `(let* ((,result ,@body))
+                       (declare (dynamic-extent ,result)
+                                (ignorable ,result))
+                       ,(funcall (ftd-callback-return-value-function *target-ftd*)
+                              stack-ptr
+                              fp-args-ptr
+                              result
+                              return-type
+                              struct-return-arg))
+                     (if (eq return-type *void-foreign-type*)
+                       `(progn ,@body)
+                       (funcall (ftd-callback-return-value-function *target-ftd*)
+                                stack-ptr
+                                fp-args-ptr
+                                `(progn ,@body)
+                                return-type
+                                struct-return-arg)))
+                nil))))
       (if error-return
         (let* ((cond (gensym))
@@ -2691 +2699 @@
           `(block ,block
             (let* ((,handler (lambda (,cond)
-                                           (,error-return-function ,cond ,stack-ptr (%inc-ptr ,stack-ptr ,error-delta))
-                                           (return-from ,block
-                                             nil))))
+                               (,error-return-function ,cond ,stack-ptr (%inc-ptr ,stack-ptr ,error-delta))
+                               (return-from ,block
+                                 nil))))
               (declare (dynamic-extent ,handler))
-            (handler-bind ((,condition-name ,handler))
-              (values ,body)))))
+              (handler-bind ((,condition-name ,handler))
+                (values ,body)))))
         body))))