Changeset 9423


Ignore:
Timestamp:
May 9, 2008, 10:06:09 AM (11 years ago)
Author:
gb
Message:

Try to improve typechecking of funcallable-instances, generic-functions,
standard-generic-functions.

Register the dcode trampoline in a few cases that'd been missed.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711-perf/ccl/level-1/l1-dcode.lisp

    r9131 r9423  
    536536  (setf (combined-method.dcode cm) val))
    537537
     538(declaim (inline funcallable-instance-p))
    538539(defun funcallable-instance-p (thing)
    539540  (when (typep thing 'function)
     
    544545                               (ash 1 $lfbits-method-bit)))))))
    545546
     547(setf (type-predicate 'funcallable-standard-object) 'funcallable-instance-p)
     548
    546549(defstatic *generic-function-class-wrapper* nil)
    547550(defstatic *standard-generic-function-class-wrapper* nil)
    548551
    549552(defun generic-function-p (thing)
    550   (and (typep thing 'function)
    551        (let ((bits (lfun-bits-known-function thing)))
    552          (declare (fixnum bits))
    553          (eq (ash 1 $lfbits-gfn-bit)
    554              (logand bits (logior (ash 1 $lfbits-gfn-bit)
    555                                   (ash 1 $lfbits-method-bit)))))
     553  (and (typep thing 'funcallable-standard-object)
    556554       (let* ((wrapper (gf.instance.class-wrapper thing)))
    557          ;; In practice, many generic-functions are standard-generic-functions.
    558          (or (eq *standard-generic-function-class-wrapper* wrapper)
     555         ;; In practice, many generic-functions are standard-generic-functions.         (or (eq *standard-generic-function-class-wrapper* wrapper)
    559556             (eq *generic-function-class-wrapper* wrapper)
    560              (memq  *generic-function-class*
    561                   (%inited-class-cpl (class-of thing)))))))
     557             (let* ((bits (or (%wrapper-cpl-bits wrapper)
     558                              (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper)))))
     559                    (ordinal (%wrapper-class-ordinal *generic-function-class-wrapper*)))
     560               (and bits ordinal
     561                    (locally (declare (simple-bit-vector bits)
     562                                      (fixnum ordinal)
     563                                      (optimize (speed 3) (safety 0)))
     564                      (and (< ordinal (length bits))
     565                           (eql 1 (sbit bits ordinal)))))))))
    562566
    563567
     
    803807      (apply method args))))
    804808
     809(register-dcode-proto #'%%0-arg-dcode *gf-proto*)
     810
    805811(defun dcode-too-few-args (arg-count cm-or-gf)
    806812  (error (make-condition 'too-few-arguments
     
    822828      (let ((method (%find-1st-arg-combined-method dt (%car args))))
    823829        (apply method args)))))
    824 
     830(register-dcode-proto #'%%1st-arg-dcode *gf-proto*)
    825831
    826832(defun %%one-arg-dcode (dt  arg)
     
    851857      (let ((method (%find-nth-arg-combined-method dt (%lexpr-ref args args-len argnum) args)))
    852858        (%apply-lexpr-tail-wise method args)))))
     859(register-dcode-proto #'%%nth-arg-dcode *gf-proto*)
    853860
    854861
     
    15281535
    15291536
     1537
    15301538(defun %%hash-table-combined-method-dcode (stuff args)
    15311539  ;; stuff is (argnum eql-hash-table . default-method)
Note: See TracChangeset for help on using the changeset viewer.