Changeset 9418


Ignore:
Timestamp:
May 9, 2008, 9:18:36 AM (11 years ago)
Author:
gb
Message:

Do STRING-EQUAL differently.

Do INTERN, FIND-SYMBOL, FIND-PACKAGE, and CCL::PKG-ARG with a constant,
stringable package-name arg via a "package-refrence" (a little structure
that maps package names to packages.) There's runtime support intended
to keep "package-referencess" up-to-date as packages are named/renamed,
so the transformed versions of these functions should do package-name
lookups in unit time.

Add compiler-macro. for (new) %CLASS-ORDINAL.

When SUBTYPEP's second argument is a constant type-specifier, use a
TYPE-REFERENCE structure to map the type-specifier to a CTYPE. Probably
needs more runtime support to handle redefinition of types.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711-perf/ccl/compiler/optimizers.lisp

    r9390 r9418  
    567567(defun package-designator-p (object)
    568568  (or (string-designator-p object) (packagep object)))
    569 
    570 (define-compiler-macro intern (&whole call str &optional package)
    571   (if (or (and (quoted-form-p package) (package-designator-p (%cadr package)))
    572           (keywordp package)
    573           (stringp package))
    574     `(intern ,str (load-time-value (or (find-package ,package) ,package)))
    575     call))
    576569
    577570(define-compiler-macro ldb (&whole call &environment env byte integer)
     
    18971890        (= ,gtype ,(nx-lookup-target-uvector-subtag :simple-string))))))
    18981891
    1899 (define-compiler-macro string-equal (&whole call string1 string2
    1900                                             &environment env
    1901                                             &rest keys)
    1902   (if (null keys)
    1903     (if (and (nx-form-typep string1 'simple-string env)
    1904              (nx-form-typep string2 'simple-string env))
    1905       (once-only ((string1 string1)
    1906                   (string2 string2)
    1907                   (len1 `(length ,string1))
    1908                   (len2 `(length ,string2)))
    1909         `(and (eq ,len1 ,len2)
    1910               (%string-equal ,string1 0 ,len1 ,string2 0 ,len2)))
    1911       `(string-equal-no-keys ,string1 ,string2))
    1912     call))
     1892
    19131893
    19141894(defsetf %misc-ref %misc-set)
     
    21252105          (foreign-instance-class-wrapper ,temp))))))
    21262106
     2107(define-compiler-macro %class-ordinal (class &optional error)
     2108  (let* ((temp (gensym)))
     2109    `(let* ((,temp ,class))
     2110      (if (eql (the (unsigned-byte 8) (typecode ,temp))
     2111               ,(nx-lookup-target-uvector-subtag :instance))
     2112        (instance.hash ,temp)
     2113        (funcall '%class-ordinal ,temp ,error)))))
     2114
     2115
    21272116(define-compiler-macro unsigned-byte-p (x)
    21282117  (if (typep (nx-unquote x) 'unsigned-byte)
     
    21322121        (and (integerp ,val) (not (< ,val 0)))))))
    21332122
     2123(define-compiler-macro subtypep (&whole w t1 t2 &optional rtenv  &environment env)
     2124  (declare (ignorable rtenv))
     2125  (if (and (consp t1)
     2126           (consp (cdr t1))
     2127           (null (cddr t1))
     2128           (eq (car t1) 'type-of))
     2129    ;; People really write code like this.  I've seen it.
     2130    `(typep ,(cadr t1) ,t2)
     2131    (if (quoted-form-p t2)
     2132      `(cell-csubtypep-2 ,t1 (load-time-value (register-type-cell ,t2)))
     2133      w)))
     2134
     2135
     2136(define-compiler-macro string-equal (&whole w s1 s2 &rest keys)
     2137  (if (null keys)
     2138    `(%fixed-string-equal ,s1 ,s2)
     2139    (let* ((s1-arg (gensym))
     2140           (s2-arg (gensym)))
     2141      `(funcall
     2142        (lambda (,s1-arg ,s2-arg &key start1 end1 start2 end2)
     2143          (%bounded-string-equal ,s1-arg ,s2-arg start1 end1 start2 end2))
     2144        ,s1 ,s2 ,@keys))))
     2145
     2146;;; Try to use "package-references" to speed up package lookup when
     2147;;; a package name is used as a constant argument to some functions.
     2148
     2149(defun package-ref-form (arg)
     2150  (when (and arg (constantp arg) (typep (setq arg (nx-unquote arg))
     2151                                        '(or symbol string)))
     2152    `(load-time-value (register-package-ref ,(string arg)))))
     2153
     2154
     2155(define-compiler-macro intern (&whole w string &optional package)
     2156  (let* ((ref (package-ref-form package)))
     2157    (if (or ref
     2158            (setq ref (and (consp package)
     2159                           (eq (car package) 'find-package)
     2160                           (consp (cdr package))
     2161                           (null (cddr package))
     2162                           (package-ref-form (cadr package)))))
     2163      `(%pkg-ref-intern ,string ,ref)
     2164      w)))
     2165
     2166(define-compiler-macro find-symbol (&whole w string &optional package)
     2167  (let* ((ref (package-ref-form package)))
     2168    (if (or ref
     2169            (setq ref (and (consp package)
     2170                           (eq (car package) 'find-package)
     2171                           (consp (cdr package))
     2172                           (null (cddr package))
     2173                           (package-ref-form (cadr package)))))
     2174      `(%pkg-ref-find-symbol ,string ,ref)
     2175      w)))
     2176
     2177(define-compiler-macro find-package (&whole w package)
     2178  (let* ((ref (package-ref-form package)))
     2179    (if ref
     2180      `(package-ref.pkg ,ref)
     2181      w)))
     2182
     2183(define-compiler-macro pkg-arg (&whole w package &optional allow-deleted)
     2184  (let* ((ref (unless allow-deleted (package-ref-form package))))
     2185    (if ref
     2186      (let* ((r (gensym)))
     2187        `(let* ((,r ,ref))
     2188          (or (package-ref.pkg ,ref)
     2189           (%kernel-restart $xnopkg (package-ref.pkg ,r)))))
     2190      w)))
     2191
     2192
     2193;;; In practice, things that're STREAMP are almost always
     2194;;; BASIC-STREAMs or FUNDAMENTAL-STREAMs, but STREAMP is a generic
     2195;;; function.
     2196(define-compiler-macro streamp (arg)
     2197  (let* ((s (gensym)))
     2198    `(let* ((,s ,arg))
     2199      (or (typep ,s 'basic-stream)
     2200       (typep ,s 'fundamental-stream)
     2201       ;; Don't recurse
     2202       (funcall 'streamp ,s)))))
     2203
     2204
     2205
    21342206(provide "OPTIMIZERS")
Note: See TracChangeset for help on using the changeset viewer.