Changeset 9500


Ignore:
Timestamp:
May 15, 2008, 11:47:14 PM (11 years ago)
Author:
gb
Message:

In OPTIMIZE-TYPEP: if the type names an istruct class and that
class has no subclasses, do ISTRUCT-TYPEP. (We've had a few dozen
predicates that do exactly this; doing it here should work in
cases where we forgot to define a predicate and makes many of
those predicates redundant.)

STRUCTURE-TYPEP: Pass the the class cell if the class name's constant.
(There's a warnlng about non-constant type names here; I think that that'd
indicate a problem with our code and the user would never see it.)

Turn SLOT-BOUNDP with a constant slot name into SLOT-ID-BOUNDP (this
should be faster, but who calls SLOT-BOUNDP often enough for it to
matter ?)

STRUCTUREP: just look at the typecode.

NATIVE-CLASS-P: inline a new primitive.

char-code case-folding stuff, mostly (> speed space).

REGISTER-ISTRUCT-CELL.

File:
1 edited

Legend:

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

    r9487 r9500  
    15261526                                  `(typep ,thing ',expanded-type))))
    15271527                           ((structure-class-p type env)
    1528                             `(structure-typep ,thing ',type))
     1528                            `(structure-typep ,thing ',(find-class-cell type t)))
    15291529                           ((find-class type nil env)
    1530                             `(class-cell-typep ,thing (load-time-value (find-class-cell ',type t))))
     1530                            (let* ((class (find-class type nil)))
     1531                              (if (and class
     1532                                       (subtypep class *istruct-class*)
     1533                                       (null (class-direct-subclasses class)))
     1534                                `(istruct-typep ,thing ',type)
     1535                                `(class-cell-typep ,thing (load-time-value (find-class-cell ',type t))))))
    15311536                           ((info-type-builtin type) ; bootstrap troubles here?
    15321537                            `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
     
    15651570      call)))
    15661571
     1572(define-compiler-macro structure-typep (&whole w thing type)
     1573  (if (not (quoted-form-p type))
     1574    (progn
     1575      (warn "Non-qouted structure-type in ~s" w)
     1576      w)
     1577    (let* ((type (nx-unquote type)))
     1578      (if (symbolp type)
     1579        `(structure-typep ,thing ',(find-class-cell type t))
     1580        w))))
     1581
    15671582(define-compiler-macro true (&rest args)
    15681583  `(progn
     
    17071722
    17081723
    1709 
     1724(define-compiler-macro slot-boundp (&whole whole instance slot-name-form)
     1725  (declare (ignore env))
     1726  (let* ((name (and (quoted-form-p slot-name-form)
     1727                    (typep (cadr slot-name-form) 'symbol)
     1728                    (cadr slot-name-form))))
     1729    (if name
     1730      `(slot-id-boundp ,instance (load-time-value (ensure-slot-id ',name)))
     1731      whole)))
    17101732
    17111733(defsynonym %get-unsigned-byte %get-byte)
     
    20032025    `(eq ,tag (typecode ,lock))))
    20042026
     2027(define-compiler-macro structurep (s)
     2028  (let* ((tag (nx-lookup-target-uvector-subtag :struct)))
     2029    `(eq ,tag (typecode ,s))))
     2030 
    20052031
    20062032(define-compiler-macro integerp (thing)
     
    20652091  (if (null others)
    20662092    (if other-p
    2067       `(eq (%char-code (char-upcase ,ch)) (%char-code (char-upcase ,other)))
     2093      `(eq (%char-code-upcase (char-code ,ch)) (%char-code-upcase (char-code ,other)))
    20682094      `(progn (char-code ,ch) t))
    20692095    (if (null (cdr others))
    20702096      (let* ((third (car others))
    20712097             (code (gensym)))
    2072         `(let* ((,code (%char-code (char-upcase ,ch))))
    2073           (and (eq ,code (setq ,code (%char-code (char-upcase ,other))))
    2074            (eq ,code (%char-code (char-upcase ,third))))))
     2098        `(let* ((,code (%char-code-upcase (char-code ,ch))))
     2099          (and (eq ,code (setq ,code (%char-code-upcase (char-code ,other))))
     2100           (eq ,code (%char-code-upcase (char-code ,third))))))
    20752101      call)))
    20762102
     
    22182244        (funcall '%class-ordinal ,temp ,error)))))
    22192245
     2246(define-compiler-macro native-class-p (class)
     2247  (let* ((temp (gensym)))
     2248    `(let* ((,temp ,class))
     2249      (if (eql (the (unsigned-byte 8) (typecode ,temp))
     2250               ,(nx-lookup-target-uvector-subtag :instance))
     2251        (< (the fixnum (instance.hash ,temp)) max-class-ordinal)))))
     2252 
     2253
    22202254
    22212255(define-compiler-macro unsigned-byte-p (x)
     
    23072341
    23082342
     2343(define-compiler-macro %char-code-case-fold (&whole w code vector &environment env)
     2344  (if (nx-open-code-in-line env)
     2345    (let* ((c (gensym))
     2346           (table (gensym)))
     2347      `(let* ((,c ,code)
     2348              (,table ,vector))
     2349        (declare (type (mod #x110000) ,c)
     2350                 (type (simple-array (signed-byte 16) (*)) ,table))
     2351        (if (< ,c (length ,table))
     2352          (the fixnum (+ ,c (the (signed-byte 16)
     2353                              (locally (declare (optimize (speed 3) (safety 0)))
     2354                                (aref ,table ,c)))))
     2355          ,c)))
     2356    w))
     2357       
     2358(define-compiler-macro %char-code-upcase (&whole w code &environment env)
     2359  (if (typep code '(mod #x110000))
     2360    (%char-code-upcase code)
     2361    `(%char-code-case-fold ,code *lower-to-upper*)))
     2362
     2363(define-compiler-macro %char-code-downcase (&whole w code &environment env)
     2364  (if (typep code '(mod #x110000))
     2365    (%char-code-downcase code)
     2366    `(%char-code-case-fold ,code *upper-to-lower*)))
     2367
     2368(define-compiler-macro char-upcase (char)
     2369  `(code-char (%char-code-upcase (char-code ,char))))
     2370
     2371
     2372(define-compiler-macro register-istruct-cell (&whole w arg)
     2373  (if (and (quoted-form-p arg)
     2374           (cadr arg)
     2375           (typep (cadr arg) 'symbol))
     2376    `',(register-istruct-cell (cadr arg))
     2377    w))
    23092378
    23102379(provide "OPTIMIZERS")
Note: See TracChangeset for help on using the changeset viewer.