Changeset 12741


Ignore:
Timestamp:
Sep 2, 2009, 4:58:16 PM (10 years ago)
Author:
gb
Message:

Compile named functions (rather than closures) to do ObjC message
dispatch, solely so that backtraces will contain more meaningful
names. TODO: maybe put some effort into not recompiling when
nothing changes, but the functions are tiny and that may not be
worth the effort.
This may introduce some (more) LOAD-TIME-VALUE issues if dispatch
functions are ever fasdumped; I don't think that worked before this
change and the couple of MAKE-LOAD-FORM methods added here probably
aren't enough to make that work.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/source/objc-bridge/bridge.lisp

    r12549 r12741  
    759759
    760760(defun objc-method-signature-info (sig)
    761   (or (gethash sig *objc-method-signatures*)
    762       (setf (gethash sig *objc-method-signatures*)
    763             (make-objc-method-signature-info
    764              :type-signature sig
    765              :function (compile-send-function-for-signature  sig)
    766              :super-function (%compile-send-function-for-signature  sig t)))))
     761  (values
     762   (or (gethash sig *objc-method-signatures*)
     763       (setf (gethash sig *objc-method-signatures*)
     764             (make-objc-method-signature-info
     765              :type-signature sig
     766              :function (compile-send-function-for-signature  sig)
     767              :super-function (%compile-send-function-for-signature  sig t))))))
     768
     769(defmethod make-load-form ((siginfo objc-method-signature-info) &optional env)
     770  (declare (ignore env))
     771  `(objc-method-signature-info ',(objc-method-signature-info-type-signature siginfo)))
    767772
    768773(defun concise-foreign-type (ftype)
    … …  
    817822(defmethod shared-initialize :after ((gf objc-dispatch-function) slot-names &key message-info &allow-other-keys)
    818823  (declare (ignore slot-names))
    819   (if message-info
    820     (let* ((ambiguous-methods (getf (objc-message-info-flags message-info) :ambiguous))
    821            (selector (objc-message-info-selector message-info))
    822            (first-method (car (objc-message-info-methods message-info))))
    823       (lfun-bits gf (dpb (1+ (objc-message-info-req-args message-info))
    824                          $lfbits-numreq
    825                          (logior (ash
    826                                   (if (getf (objc-message-info-flags message-info)
    827                                             :accepts-varargs)
    828                                     1
    829                                     0)
    830                                   $lfbits-rest-bit)
    831                                  (logandc2 (lfun-bits gf) (ash 1 $lfbits-aok-bit)))))
    832       (flet ((signature-function-for-method (m)
    833                (let* ((signature-info (objc-method-info-signature-info m)))
    834                  (or (objc-method-signature-info-function signature-info)
    835                      (setf (objc-method-signature-info-function signature-info)
    836                            (compile-send-function-for-signature
    837                                     (objc-method-signature-info-type-signature signature-info)))))))
    838                      
    839       (if (null ambiguous-methods)
    840         ;; Pick an arbitrary method, since all methods have the same
    841         ;; signature.
    842         (let* ((function (signature-function-for-method first-method)))
    843           (set-funcallable-instance-function
    844            gf
    845            (nfunction
    846             send-unambiguous-message
    847             (lambda (receiver &rest args)
    848                (declare (dynamic-extent args))
    849                (or (check-receiver receiver)
    850                    (with-ns-exceptions-as-errors
    851                        (apply function receiver selector args)))))))
    852         (let* ((protocol-pairs (mapcar #'(lambda (pm)
    853                                            (cons (lookup-objc-protocol
    854                                                   (objc-method-info-class-name pm))
    855                                                  (signature-function-for-method
    856                                                   pm)))
    857                                        (objc-message-info-protocol-methods message-info)))
    858                (method-pairs (mapcar #'(lambda (group)
    859                                          (cons (mapcar #'(lambda (m)
    860                                                            (get-objc-method-info-class m))
    861                                                        group)
    862                                                (signature-function-for-method (car group))))
    863                                      (objc-message-info-ambiguous-methods message-info)))
    864                (default-function (if method-pairs
    865                                    (prog1 (cdar (last method-pairs))
    866                                      (setq method-pairs (nbutlast method-pairs)))
    867                                    (prog1 (cdr (last protocol-pairs))
    868                                      (setq protocol-pairs (nbutlast protocol-pairs))))))
    869           (set-funcallable-instance-function
    870            gf
    871            (nfunction
    872             send-unambiguous-message
    873             (lambda (receiver &rest args)
    874                (declare (dynamic-extent args))
    875                (or (check-receiver receiver)
     824  (with-slots (name) gf
     825    (if message-info
     826      (let* ((ambiguous-methods (getf (objc-message-info-flags message-info) :ambiguous))
     827             (selector (objc-message-info-selector message-info))
     828             (first-method (car (objc-message-info-methods message-info))))
     829        (lfun-bits gf (dpb (1+ (objc-message-info-req-args message-info))
     830                           $lfbits-numreq
     831                           (logior (ash
     832                                    (if (getf (objc-message-info-flags message-info)
     833                                              :accepts-varargs)
     834                                      1
     835                                      0)
     836                                    $lfbits-rest-bit)
     837                                   (logandc2 (lfun-bits gf) (ash 1 $lfbits-aok-bit)))))
     838        (flet ((signature-function-for-method (m)
     839                 (let* ((signature-info (objc-method-info-signature-info m)))
     840                   (or (objc-method-signature-info-function signature-info)
     841                       (setf (objc-method-signature-info-function signature-info)
     842                             (compile-send-function-for-signature
     843                              (objc-method-signature-info-type-signature signature-info)))))))
     844          (if (null ambiguous-methods)
     845            ;; Pick an arbitrary method, since all methods have the same
     846            ;; signature.
     847            (set-funcallable-instance-function
     848             gf
     849             (compile-named-function
     850              `(lambda (receiver &rest args)
     851                (declare (dynamic-extent args))
     852                (or (check-receiver receiver)
     853                 (with-ns-exceptions-as-errors
     854                     (apply (objc-method-signature-info-function
     855                             (load-time-value                               
     856                              (objc-method-info-signature-info ,first-method)))
     857                            receiver ,selector args))))
     858              :name `(:objc-dispatch ,name)))
     859            (let* ((protocol-pairs (mapcar #'(lambda (pm)
     860                                               (cons (lookup-objc-protocol
     861                                                      (objc-method-info-class-name pm))
     862                                                     (objc-method-info-signature-info
     863                                                      pm)))
     864                                           (objc-message-info-protocol-methods message-info)))
     865                   (method-pairs (mapcar #'(lambda (group)
     866                                             (cons (mapcar #'(lambda (m)
     867                                                               (get-objc-method-info-class m))
     868                                                           group)
     869                                                   (objc-method-info-signature-info (car group))))
     870                                         (objc-message-info-ambiguous-methods message-info)))
     871                   (default-function-info (if method-pairs
     872                                            (prog1 (cdar (last method-pairs))
     873                                              (setq method-pairs (nbutlast method-pairs)))
     874                                            (prog1 (cdr (last protocol-pairs))
     875                                              (setq protocol-pairs (nbutlast protocol-pairs))))))
     876              (set-funcallable-instance-function
     877               gf
     878               (compile-named-function
     879                `(lambda (receiver &rest args)
     880                  (declare (dynamic-extent args))
     881                  (or (check-receiver receiver)
    876882                   (let* ((function
    877                            (or (dolist (pair protocol-pairs)
    878                                  (when (conforms-to-protocol receiver (car pair))
    879                                    (return (cdr pair))))
    880                                (block m
    881                                  (dolist (pair method-pairs default-function)
    882                                    (dolist (class (car pair))
    883                                      (when (typep receiver class)
    884                                        (return-from m (cdr pair)))))))))
     883                           (objc-method-signature-info-function
     884                            (or (dolist (pair ',protocol-pairs)
     885                                  (when (conforms-to-protocol receiver (car pair))
     886                                    (return (cdr pair))))
     887                                (block m
     888                                  (dolist (pair ',method-pairs ,default-function-info)
     889                                    (dolist (class (car pair))
     890                                      (when (typep receiver class)
     891                                        (return-from m (cdr pair))))))))))
    885892                     (with-ns-exceptions-as-errors
    886                          (apply function receiver selector args)))))))))))
    887     (with-slots (name) gf
     893                         (apply function receiver ,selector args)))))
     894                :name `(:objc-dispatch ,name)))))))
    888895      (set-funcallable-instance-function
    889896       gf
Note: See TracChangeset for help on using the changeset viewer.