Changeset 7838


Ignore:
Timestamp:
Dec 7, 2007, 3:37:28 AM (13 years ago)
Author:
gb
Message:

Sleazy hack to try to improve some cases of EQL method dispatch.

File:
1 edited

Legend:

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

    r7825 r7838  
    18641864                             alist
    18651865                             
    1866                              (gf.dcode f) #'reader-variable-location-dcode)))))))))))                       
    1867 
     1866                             (gf.dcode f) #'reader-variable-location-dcode)))))))))))
     1867
     1868;;; Hack-o-rama: GF has nothing but primary methods, first (and only non-T)
     1869;;; specializers are all EQL specializers whose objects are symbols.
     1870;;; The effective method applicable for each symbol is stored on the
     1871;;; plist of the symbol under a property EQ to the dispatch table (which
     1872;;; is mostly ignored, otherwise.)
     1873(defun %%1st-arg-eql-method-hack-dcode (dt args)
     1874  (let* ((sym (if (listp args) (car args)(%lexpr-ref args (%lexpr-count args) 0)))
     1875         (mf (if (symbolp sym) (get args dt))))
     1876    (if mf
     1877      (if (listp args)
     1878        (apply mf args)
     1879        (%apply-lexpr-tail-wise mf args))
     1880      ;;; Let %%1st-arg-dcode deal with it.
     1881      (%%1st-arg-dcode dt args))))
     1882
     1883(defun %%1st-two-arg-eql-method-hack-dcode (dt arg1 arg2)
     1884  (let* ((mf (if (typep arg1 'symbol) (get arg1 dt))))
     1885    (if mf
     1886      (funcall mf arg1 arg2)
     1887      (%%1st-two-arg-dcode dt arg1 arg2))))
     1888
     1889(defun %%one-arg-eql-method-hack-dcode (dt arg)
     1890  (let* ((mf (if (typep arg 'symbol) (get arg dt))))
     1891    (if mf
     1892      (funcall mf arg))))
     1893
     1894(defun install-eql-method-hack-dcode (gf)
     1895  (let* ((bits (inner-lfun-bits gf))
     1896         (nreq (ldb $lfbits-numreq bits))
     1897         (other-args? (or (not (eql 0 (ldb $lfbits-numopt bits)))
     1898                          (logbitp $lfbits-rest-bit bits)
     1899                          (logbitp $lfbits-restv-bit bits)
     1900                          (logbitp $lfbits-keys-bit bits)
     1901                          (logbitp $lfbits-aok-bit bits))))
     1902    (setf (%gf-dcode gf)
     1903          (cond ((and (eql nreq 1) (null other-args?))
     1904                 #'%%one-arg-eql-method-hack-dcode)
     1905                ((and (eql nreq 2) (null other-args?))
     1906                 #'%%1st-two-arg-eql-method-hack-dcode)
     1907                (t
     1908                 #'%%1st-arg-eql-method-hack-dcode)))))
     1909
     1910 
     1911 
     1912
     1913
     1914(defun maybe-hack-eql-methods (gf)
     1915  (let* ((methods (generic-function-methods gf)))
     1916    (when (and methods
     1917               (every #'(lambda (method)
     1918                          (let* ((specializers (method-specializers method))
     1919                                      (first (car specializers)))
     1920                                 (and (typep first 'eql-specializer)
     1921                                      (typep (eql-specializer-object first) 'symbol)
     1922                                      (dolist (s (cdr specializers) t)
     1923                                        (unless (eq s *t-class*)
     1924                                          (return nil)))
     1925                                      (null (cdr (compute-applicable-methods gf (cons (eql-specializer-object first) (make-list (length (cdr specializers))))))))))
     1926                      methods))
     1927      (let* ((dt (%gf-dispatch-table gf)))
     1928        (dolist (m methods)
     1929          (let* ((sym (eql-specializer-object (car (method-specializers m))))
     1930                 (f (method-function m)))
     1931            (setf (get sym dt) f)))
     1932        (install-eql-method-hack-dcode gf)
     1933        t))))
     1934
     1935
     1936           
     1937                           
    18681938;;; Return a list of :after methods for INITIALIZE-INSTANCE on the
    18691939;;; class's prototype, and a boolean that's true if no other qualified
Note: See TracChangeset for help on using the changeset viewer.