Changeset 15540


Ignore:
Timestamp:
Dec 16, 2012, 10:07:47 AM (7 years ago)
Author:
gb
Message:

Add a functional interface to THROW (%THROW).

Add %THROWING-THROUGH-CLEANUP-P, which tries to determine whether
an UNWIND-PROTECT clanup was invoked in response to THROW or "just
fell in". (Both of these functions are currently only implemented
on x86; they're primarily intended to be used in the ObjC bridge,
and the bridge is currently effectively x86-only.)

Add a :PROPAGATE-THROW option to DEFCALLBACK; it and the :ERROR-RETURN
option are incompatible. The :PROPAGATE-THROW option can be used
to specify a function which can arrange that foreign cleanup code
(as established by ObjC exception handlers) is run on attempts to
"throw through them".

Make the ObjC bridge use the new mechanism to ensure that throwing
through ObjC handlers works without affecting condition handling
in methods defined by OBJC:DEFMETHOD.

Warn on first use of some deprecated ObjC bridge constructs (SEND etc.)

Fixes ticket:682 in the trunk.

Note that there may be code which has depended on the old behavior
(and that code could include the CCL IDE's handling of exception
on the event thread.) Standard CL condition-handling facilities
should work a lot better in the presence of ObjC callbacks now, and
using those facilities is likely the best approach to dealing with
any problems that arise.

Location:
trunk/source
Files:
7 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-0/X86/X8632/x8632-def.lisp

    r13067 r15540  
    689689                   (:double-float (%get-double-float argptr 4)))))))))))
    690690
     691(defx8632lapfunction %throw ()
     692  (push-argregs)
     693  (subl ($ x8632::fixnumone) (% nargs))
     694  (lea (:@ (:^ @back) (% fn)) (% temp0))
     695  (:talign 5)
     696  (jmp-subprim .SPthrow)
     697  @back
     698  (recover-fn)
     699  (uuo-error-reg-not-tag (% temp0) ($ x8632::subtag-catch-frame)))
     700
    691701;;; end of x86-def.lisp
  • trunk/source/level-0/X86/x86-def.lisp

    r14156 r15540  
    835835                   (:double-float (%get-double-float argptr 16))))))))))
    836836
     837(defx86lapfunction %throw ()
     838  (:arglist (&rest args))
     839  (push-argregs)
     840  (subl ($ x8664::fixnumone) (% nargs))
     841  (lea (:@ (:^ @back) (% fn)) (% ra0))
     842  (:talign 4)
     843  (jmp-subprim .SPthrow)
     844  @back
     845  (recover-fn-from-rip)
     846  (uuo-error-reg-not-tag (% temp0) ($ x8664::subtag-catch-frame)))
     847
    837848
    838849                                 
  • trunk/source/level-0/l0-def.lisp

    r15122 r15540  
    260260  newval)
    261261
     262(defun nth-catch-frame-tag (n)
     263  (declare (fixnum n))
     264  (let* ((frame (%catch-top (%current-tcr))))
     265    (dotimes (i n (%svref frame target::catch-frame.catch-tag-cell))
     266      (setq frame (%svref frame target::catch-frame.link-cell)))))
     267
     268;;; This function is magic, and it can only be called from
     269;;; an unwind-protect cleanup form (making it even more magic.)
     270;;; If we can tell that we reached the unwind-protect via THROW,
     271;;; return a list of the target catch tag and all values being
     272;;; thrown.
     273#+x86-target
     274(defun %throwing-through-cleanup-p ()
     275  ;; when we enter and unwind-protect cleanup on x8664, the
     276  ;; top frame on the tstack contains state information that's
     277  ;; used both by THROW and by normal exit from the protected
     278  ;; form.  That state information contains a count of the number
     279  ;; of catch/unwind-protect frames still to be processed (non-zero
     280  ;; only in the case where we're actually throwing), the value(s)
     281  ;; being thrown, and a return address that isn't interesting to
     282  ;; us.  It's an historical accident that that information is stored
     283  ;; differently in the cases where a single value is being thrown
     284  ;; and multiple values are thrown.
     285  ;; A tstack frame is always doubleword aligned, and the first two
     286  ;; words are a backpointer to the previous tstack frame and a
     287  ;; pointer into the main lisp stack.  In the single value case,
     288  ;; we then have 3 words: return address, frame count, value;
     289  ;; in the multiple-value we have 3 fixed words (value count,
     290  ;; return address, frame count) with the values following the
     291  ;; frame count (value 0 follows immediately.)
     292  ;; A cleanup form is always called from either .SPnthrowvalues
     293  ;; of .SPnthrow1value, and those subprims can be called either
     294  ;; by .SPthrow (in which case the return address in the frame
     295  ;; will have no function associated with it) or by Lisp code
     296  ;; (in which case it will.)
     297  ;; We (have to) just assume that the frame on top of the temp
     298  ;; stack is context info for the nthrow stuff.  Tracing this
     299  ;; function may violate this assumption and cause misbehavior
     300  ;; here.
     301  (let* ((frame (%current-tsp))
     302         (single-value-case (not (typep (%lisp-word-ref frame 2) 'fixnum)))
     303         (frame-count (%lisp-word-ref frame (if single-value-case 3 4)))
     304         (throwing (null (%return-address-function (if single-value-case
     305                                                     (%lisp-word-ref frame 2)
     306                                                     (%lisp-word-ref frame 3))))))
     307    (declare (fixnum frame))
     308    (if throwing
     309      (collect ((info))
     310        (info (nth-catch-frame-tag frame-count))
     311        (if single-value-case
     312          (info (%lisp-word-ref frame 4))
     313          (let* ((valptr (+ frame 5)))
     314            (declare (fixnum valptr))
     315            (dotimes (i (%lisp-word-ref frame 2))
     316              (declare (fixnum i))
     317              (info (%lisp-word-ref valptr i)))))
     318        (info)))))
     319
    262320;;; end of l0-def.lisp
  • trunk/source/lib/macros.lisp

    r15526 r15540  
    26602660         (need-struct-arg)
    26612661         (struct-return-arg-name)
    2662          (error-return nil))
     2662         (error-return nil)
     2663         (propagate-throw nil))
    26632664    (collect ((arg-names)
    26642665              (arg-specs))
     
    26822683                    (cadr args)                 
    26832684                    args (cddr args))
    2684               (if need-struct-arg
    2685                 (setq struct-return-arg-name (pop args) need-struct-arg nil)
    2686                 (progn
    2687                   (arg-specs (pop args))
    2688                   (arg-names (pop args))))))))
     2685              (if (eq (car args) :propagate-throw)
     2686                (setq propagate-throw (cadr args)
     2687                      args (cddr args))
     2688                (if need-struct-arg
     2689                  (setq struct-return-arg-name (pop args) need-struct-arg nil)
     2690                  (progn
     2691                    (arg-specs (pop args))
     2692                    (arg-names (pop args)))))))))
     2693      (when (and error-return propagate-throw)
     2694        (error "Can't specify both :ERROR-RETURN and :PROPAGATE-THROW in callback definition for ~s." name))
    26892695      (multiple-value-bind (rlets lets dynamic-extent-names inits foreign-return-type fp-args-form error-return-offset num-arg-bytes)
    26902696          (funcall (ftd-callback-bindings-function *target-ftd*)
     
    27282734                                            error-return
    27292735                                            error-return-offset
     2736                                            propagate-throw
    27302737                                            ))))))
    27312738                ,doc
     
    27362743(defun defcallback-body (&rest args)
    27372744  (declare (dynamic-extent args))
    2738   (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
     2745  (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 propagate-throw) args
    27392746    (declare (ignorable dynamic-extent-decls))
    27402747    (let* ((condition-name (if (atom error-return) 'error (car error-return)))
     
    27782785              (handler-bind ((,condition-name ,handler))
    27792786                (values ,body)))))
    2780         body))))
     2787        (if propagate-throw
     2788          (let* ((throw-context (gensym))
     2789                 (block (gensym)))
     2790            `(block ,block
     2791              (unwind-protect
     2792                   (progn ,body)
     2793                (let* ((,throw-context (%throwing-through-cleanup-p)))
     2794                  (when ,throw-context
     2795                    (,propagate-throw ,throw-context ,stack-ptr (%inc-ptr ,stack-ptr ,error-delta))
     2796                    (return-from ,block nil))))))
     2797          body)))))
    27812798
    27822799
  • trunk/source/objc-bridge/bridge.lisp

    r14735 r15540  
    11541154;;; The SEND and SEND/STRET macros
    11551155
    1156 (defmacro send (o msg &rest args &environment env)
     1156(defmacro send (&whole w o msg &rest args &environment env)
     1157  (warn-about-deprecated-objc-bridge-construct w "#/ syntax")
    11571158  (make-optimized-send o msg args env))
    11581159
    1159 (defmacro send/stret (s o msg &rest args &environment env)
     1160(defmacro send/stret (&whole w s o msg &rest args &environment env)
     1161  (warn-about-deprecated-objc-bridge-construct w "#/ syntax")
    11601162  (make-optimized-send o msg args env s))
    11611163
  • trunk/source/objc-bridge/objc-runtime.lisp

    r15476 r15540  
    650650
    651651
     652       
     653
    652654
    653655
     
    29672969            (defcallback ,impname
    29682970                (:without-interrupts nil
    2969                  #+(and openmcl-native-threads (or apple-objc cocotron-objc)) :error-return
    2970                  #+(and openmcl-native-threads (or apple-objc cocotron-objc))  (condition objc-callback-error-return) ,@params ,resulttype)
     2971                 #+(and openmcl-native-threads (or apple-objc cocotron-objc)) :propagate-throw
     2972                 #+(and openmcl-native-threads (or apple-objc cocotron-objc))  objc-propagate-throw ,@params ,resulttype)
    29712973              (declare (ignorable ,_cmd))
    29722974              ,@decls
     
    30023004             ,class-p)))))))
    30033005
    3004 (defmacro define-objc-method ((selector-arg class-arg)
     3006(defmacro define-objc-method (&whole w (selector-arg class-arg)
    30053007                              &body body &environment env)
     3008  (warn-about-deprecated-objc-bridge-construct w "OBJC:DEFMETHOD")
    30063009  (objc-method-definition-form nil selector-arg class-arg body env))
    30073010
    3008 (defmacro define-objc-class-method ((selector-arg class-arg)
     3011(defmacro define-objc-class-method (&whole w (selector-arg class-arg)
    30093012                                     &body body &environment env)
     3013  (warn-about-deprecated-objc-bridge-construct w "OBJC:DEFMETHOD")
    30103014  (objc-method-definition-form t selector-arg class-arg body env))
    30113015
     
    31233127                 ',result-type
    31243128                 ',(cddr arg-types))
    3125                 (defcallback ,impname ( :error-return (,*objc-error-return-condition* objc-callback-error-return) ,@(arglist))
     3129                (defcallback ,impname ( :propagate-throw objc-propagate-throw ,@(arglist))
    31263130                  (declare (ignorable ,self-name)
    31273131                           (unsettable ,self-name)
     
    31533157  #+gnu-objc (#_method_get_number_of_arguments m))
    31543158
    3155 #+(and bad-idea (or apple-objc cocotron-objc))
    3156 (progn
    3157 (defloadvar *original-deallocate-hook* nil)
    3158 
    3159 ;;; At one point in the past, an earlier version of
    3160 ;;; this code caused problems.  When a thread exits
    3161 ;;; and runs tls deallocation code, Mach used to remove
    3162 ;;; the message port that enabled it to respond to
    3163 ;;; asynchonous signals.  Some of that deallocation
    3164 ;;; code involved running this callback, and that meant
    3165 ;;; that callbacks were run on a thread that couldn't
    3166 ;;; be interrupted (and that could cause GC and other
    3167 ;;; problems.)
    3168 ;;; I don't know if that's still a problem; if it is,
    3169 ;;; we probably have to give up on this idea.
    3170 ;;; It's silly (and somewhat expensive) to call REMHASH
    3171 ;;; every time an NSObject gets freed; it's only necessary
    3172 ;;; to do this for instances of lisp-defined ObjC classes
    3173 ;;; that implement lisp slots.
    3174 ;;; One somewhat fascist approach would be:
    3175 ;;; - the user is prohibited from defining a dealloc method
    3176 ;;;   on their classes.
    3177 ;;; - for classes whose instances need lisp slot vectors,
    3178 ;;;   we automatically define a dealloc method which does
    3179 ;;;   the remhash and calls the next method.
    3180 
    3181 ;;; ticket:706 suggests that people and libraries are using the
    3182 ;;; lisp-slot-on-foreign-object mechanism enough that it's
    3183 ;;; not acceptable to leave slot-vectors associated with (possibly
    3184 ;;; deallocated) NSObjects.  (Another, unrelated object gets created
    3185 ;;; at the same address as the deallocated object and winds up
    3186 ;;; getting the deallocated object's slot-vector.)
    3187 (defcallback deallocate-nsobject (:address obj :void)
    3188   (declare (dynamic-extent obj))
    3189   (unless (%null-ptr-p obj)
    3190     (remhash obj *objc-object-slot-vectors*))
    3191   (ff-call *original-deallocate-hook* :address obj :void))
    3192 
    3193 (defun install-lisp-deallocate-hook ()
    3194   (let* ((class (@class "NSObject"))
    3195          (sel (@selector "dealloc")))
    3196     (setq *original-deallocate-hook* (#_class_getMethodImplementation class sel))
    3197     (with-cstrs ((types (encode-objc-method-arglist '(:id) :void)))
    3198       (#_class_replaceMethod class sel deallocate-nsobject types))))
    3199 
    3200 (def-ccl-pointers install-deallocate-hook ()
    3201   (install-lisp-deallocate-hook))
    3202 
    3203 (defun uninstall-lisp-deallocate-hook ()
    3204   (clrhash *objc-object-slot-vectors*)
    3205   (let* ((class (@class "NSObject"))
    3206          (sel (@selector "dealloc")))
    3207     (with-cstrs ((types (encode-objc-method-arglist '(:id) :void)))
    3208       (#_class_replaceMethod class sel *original-deallocate-hook* types))))
    3209 
    3210 (pushnew #'uninstall-lisp-deallocate-hook *save-exit-functions* :test #'eq
    3211          :key #'function-name)
    3212 )
     3159
    32133160
    32143161 
     
    32953242    (if (%null-ptr-p exception)
    32963243      (external-call "__NSRemoveHandler2" :address nshandler :void)
    3297       (error (ns-exception->lisp-condition (%inc-ptr exception 0))))))
     3244      (if (typep exception 'encapsulated-lisp-throw)
     3245        (apply #'%throw (with-slots (id) exception
     3246                          (id-map-object *condition-id-map* id)))
     3247        (error (ns-exception->lisp-condition (%inc-ptr exception 0)))))))
    32983248
    32993249#+cocotron-objc
     
    33023252    (if (%null-ptr-p exception)
    33033253      (external-call "__NSPopExceptionFrame" :address xframe :void)
    3304       (error (ns-exception->lisp-condition (%inc-ptr exception 0))))))
    3305 
    3306 
    3307 
    3308 
     3254      (if (typep exception 'encapsulated-lisp-throw)
     3255        (apply #'%throw (with-slots (id) exception
     3256                          (id-map-object *condition-id-map* id)))
     3257        (error (ns-exception->lisp-condition (%inc-ptr exception 0)))))))
     3258
     3259
     3260
     3261
  • trunk/source/objc-bridge/objc-support.lisp

    r15057 r15540  
    66(unless (>= (parse-integer (software-version) :junk-allowed t) 10)
    77  (error "the Objective-C bridge needs at least Mac OS X 10.6"))
     8
     9(defloadvar *warned-deprecated-constructs* ())
     10
     11(defun warn-about-deprecated-objc-bridge-construct (whole alternative)
     12  (let* ((construct (car whole)))
     13    (unless (member construct *warned-deprecated-constructs*)
     14      (push construct *warned-deprecated-constructs*)
     15      (warn "~s, as used in ~s, is deprecated.  Use ~a instead."
     16            construct whole alternative))))
    817
    918(eval-when (:compile-toplevel :load-toplevel :execute)
     
    287296  (#/initWithName:reason:userInfo: self #@"lisp exception" #@"lisp exception" +null-ptr+))
    288297
     298(defclass encapsulated-lisp-throw (ns::ns-exception)
     299    ((id :foreign-type #>NSUInteger))
     300  (:metaclass ns::+ns-object))
     301
     302(objc:defmethod #/init ((self encapsulated-lisp-throw))
     303  (#/initWithName:reason:userInfo: self #@"encapsulated throw" #@"encapsulated-throw" +null-ptr+))
     304
     305(defun encapsulate-throw-info (info)
     306  (let* ((els (make-instance 'encapsulated-lisp-throw)))
     307    (setf (slot-value els 'id)
     308          (assign-id-map-id *condition-id-map* info))
     309    els))
    289310
    290311(defun recognize-objc-exception (x)
    291   (if (typep x 'ns:ns-exception)
    292     (ns-exception->lisp-condition x)))
     312  (if (typep x 'encapsulated-lisp-throw)
     313    (apply #'%throw (with-slots (id) x (id-map-object *condition-id-map* id)))
     314    (if (typep x 'ns:ns-exception)
     315      (ns-exception->lisp-condition x))))
    293316
    294317(pushnew 'recognize-objc-exception *foreign-error-condition-recognizers*)
     
    430453  nil)
    431454
     455(defun objc-propagate-throw (throw-info return-value-pointer return-address-pointer)
     456  ;; The callback glue reserves space for %rax at
     457  ;; return-value-pointer-8, for %rdx at -16, for %xmm0 at -24.  Store
     458  ;; encapsulated info about the throw in the %rax slot, the address
     459  ;; of #_objc_exception_throw in the %rdx slot, the original return
     460  ;; address in the %xmm0 slot, and force a return to the trampoline
     461  ;; code above.
     462  (setf (%get-ptr return-value-pointer -8) (encapsulate-throw-info throw-info)
     463        (%get-ptr return-value-pointer -16) (%get-ptr return-address-pointer 0)
     464        (%get-ptr return-address-pointer 0) *x8664-objc-callback-error-return-trampoline*)
     465  ;; A foreign entry point is always an integer on x8664.
     466  (let* ((addr (%reference-external-entry-point (load-time-value (external "_objc_exception_throw")))))
     467    (if (< addr 0)                      ;unlikely
     468      (setf (%%get-signed-longlong return-value-pointer -24) addr)
     469      (setf (%%get-unsigned-longlong return-value-pointer -24) addr)))
     470  nil)
     471
    432472
    433473)
     
    451491    (setf (%get-unsigned-long return-value-pointer -12 ) addr))
    452492  (setf (%get-ptr return-value-pointer -8) (ns-exception condition)
     493        (%get-ptr return-value-pointer -4) (%get-ptr return-address-pointer)
     494        (%get-ptr return-address-pointer) *x8632-objc-callback-error-return-trampoline*)
     495  nil)
     496
     497(defun objc-propagate-throw (throw-info return-value-pointer return-address-pointer)
     498  (let* ((addr (%reference-external-entry-point (load-time-value (external #+cocotron-objc "_NSRaiseException" #-cocotron-objc "__NSRaiseError")))))
     499    (setf (%get-unsigned-long return-value-pointer -12 ) addr))
     500  (setf (%get-ptr return-value-pointer -8) (encapsulate-throw-info throw-info)
    453501        (%get-ptr return-value-pointer -4) (%get-ptr return-address-pointer)
    454502        (%get-ptr return-address-pointer) *x8632-objc-callback-error-return-trampoline*)
Note: See TracChangeset for help on using the changeset viewer.