Changeset 7383


Ignore:
Timestamp:
Oct 12, 2007, 9:19:01 AM (12 years ago)
Author:
gb
Message:

Inline more.

File:
1 edited

Legend:

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

    r6473 r7383  
    135135    t))
    136136
    137 ;;; return new form if no keys (or if keys constant and specify :TEST
    138 ;;; {#'eq, #'eql} only.)
    139 (defun eq-eql-call (x l keys eq-fn  eql-fn env)
    140   (flet ((eql-to-eq ()
    141            (or (eql-iff-eq-p x env)
    142                (and (or (quoted-form-p l) (null l))
    143                     (dolist (elt (%cadr l) t)
    144                       (when (eq eq-fn 'assq) (setq elt (car elt)))
    145                       (when (and (numberp elt) (not (fixnump elt)))
    146                         (return nil)))))))
    147     (if (null keys)
    148       (list (if (eql-to-eq) eq-fn eql-fn) x l)
    149       (if (constant-keywords-p keys)
     137(defun remove-explicit-test-keyword-from-test-testnot-key (item list keys default alist testonly)
     138  (if (null keys)
     139    `(,default ,item ,list)
     140     (if (constant-keywords-p keys)
    150141        (destructuring-bind (&key (test nil test-p)
    151142                                  (test-not nil test-not-p)
    152143                                  (key nil key-p))
    153144                            keys
    154           (declare (ignore test-not key))
     145          (declare (ignore test-not))
    155146          (if (and test-p
    156                    (not test-not-p)
    157                    (not key-p)
     147                   (not test-not-p)
     148                   (or (not key-p)
     149                       (and (consp key)
     150                            (consp (%cdr key))
     151                            (null (%cddr key))
     152                            (or (eq (%car key) 'function)
     153                                (eq (%car key) 'quote))
     154                            (eq (%cadr key) 'identity)))
    158155                   (consp test)
    159156                   (consp (%cdr test))
     
    161158                   (or (eq (%car test) 'function)
    162159                       (eq (%car test) 'quote)))
    163             (let ((testname (%cadr test)))
    164               (if (or (eq testname 'eq)
    165                       (and (eq testname 'eql)
    166                            (eql-to-eq)))
    167                 (list eq-fn x l)
    168                 (if (and eql-fn (eq testname 'eql))
    169                   (list eql-fn x l))))))))))
     160            (let* ((testname (%cadr test))
     161                   (reduced (cdr (assoc testname alist))))
     162              (if reduced
     163                `(,reduced ,item ,list)
     164                `(,testonly ,item ,list ,test))))))))
     165
    170166
    171167(defun eql-iff-eq-p (thing env)
     
    174170    (if (not (self-evaluating-p thing))
    175171        (return-from eql-iff-eq-p
    176                      (nx-form-typep thing
    177                                      '(or fixnum
    178                                        #+64-bit-target single-float
    179                                        character symbol
    180                                        (and (not number) (not macptr))) env))))
     172          (or (nx-form-typep thing  'symbol env)
     173              (nx-form-typep thing 'character env)
     174              (nx-form-typep thing
     175                             '(or fixnum
     176                               #+64-bit-target single-float
     177                               symbol character
     178                               (and (not number) (not macptr))) env)))))
    181179  (or (fixnump thing) #+64-bit-target (typep thing 'single-float)
     180      (symbolp thing) (characterp thing)
    182181      (and (not (numberp thing)) (not (macptrp thing)))))
     182
     183(defun equal-iff-eql-p (thing env)
     184  (if (quoted-form-p thing)
     185    (setq thing (%cadr thing))
     186    (if (not (self-evaluating-p thing))
     187      (return-from equal-iff-eql-p
     188        (nx-form-typep thing
     189                       '(and (not cons) (not string) (not bit-vector) (not pathname)) env))))
     190  (not (typep thing '(or cons string bit-vector pathname))))
     191
    183192
    184193(defun fold-constant-subforms (call env)
     
    330339
    331340
    332 (define-compiler-macro assoc (&whole call &environment env item list &rest keys)
    333   (or (eq-eql-call item list keys 'assq 'asseql env)
     341(define-compiler-macro assoc (&whole call item list &rest keys)
     342  (or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'asseql '((eq . assq) (eql .asseql) (equal . assequal)) 'assoc-test)
    334343      call))
    335344
     345(define-compiler-macro assequal (&whole call &environment env item list)
     346  (if (or (equal-iff-eql-p item env)
     347          (and (quoted-form-p list)
     348               (proper-list-p (%cadr list))
     349               (every (lambda (x) (equal-iff-eql-p (car x) env)) (%cadr list))))
     350    `(asseql ,item ,list)
     351    call))
     352 
     353(define-compiler-macro asseql (&whole call &environment env item list)
     354  (if (or (eql-iff-eq-p item env)
     355          (and (quoted-form-p list)
     356               (proper-list-p (%cadr list))
     357               (every (lambda (x) (eql-iff-eq-p (car x) env)) (%cadr list))))
     358    `(assq ,item ,list)
     359    call))
     360
     361(define-compiler-macro assq (item list)
     362  (let* ((itemx (gensym))
     363         (listx (gensym))
     364         (pair (gensym)))
     365    `(let* ((,itemx ,item)
     366            (,listx ,list))
     367      (dolist (,pair ,listx)
     368        (when (and ,pair (eq (car ,pair) ,itemx)) (return ,pair))))))
    336369
    337370(define-compiler-macro caar (form)
     
    785818           (setq ,temp-var (setf (cdr ,temp-var) (list (funcall ,fn-var ,elt-var)))))))))
    786819
    787 (define-compiler-macro member (&whole call &environment env item list &rest keys)
    788   (or (eq-eql-call item list keys 'memq 'memeql env)
     820(define-compiler-macro member (&whole call item list &rest keys)
     821  (or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'memeql '((eq . memq) (eql . memeql) (equal . memequal)) 'member-test)
    789822      call))
    790823
     824(define-compiler-macro memequal (&whole call &environment env item list)
     825  (if (or (equal-iff-eql-p item env)
     826          (and (quoted-form-p list)
     827               (proper-list-p (%cadr list))
     828               (every #'equal-iff-eql-p (%cadr list)) env))
     829    `(memeql ,item ,list)
     830    call))
     831 
     832(define-compiler-macro memeql (&whole call &environment env item list)
     833  (if (or (eql-iff-eq-p item env)
     834          (and (quoted-form-p list)
     835               (proper-list-p (%cadr list))
     836               (every (lambda (elt) (eql-iff-eq-p elt env)) (%cadr list))))
     837    `(memq ,item ,list)
     838    call))
     839
    791840(define-compiler-macro memq (&whole call &environment env item list)
    792    ;(memq x '(y)) => (if (eq x 'y) '(y))
    793    ;Would it be worth making a two elt list into an OR?  Maybe if
    794    ;optimizing for speed...
     841  ;;(memq x '(y)) => (if (eq x 'y) '(y))
     842  ;;Would it be worth making a two elt list into an OR?  Maybe if
     843  ;;optimizing for speed...
    795844   (if (and (or (quoted-form-p list)
    796845                (null list))
    797846            (null (cdr (%cadr list))))
    798847     (if list `(if (eq ,item ',(%caadr list)) ,list))
    799      call))
     848     (let* ((x (gensym))
     849            (tail (gensym)))
     850       `(do* ((,x ,item)
     851              (,tail ,list (cdr (the list ,tail))))
     852         ((null ,tail))
     853         (if (eq (car ,tail) ,x) (return ,tail))))))
    800854
    801855(define-compiler-macro minusp (x)
     
    815869            (%i< count 3))
    816870     `(,(svref '#(car cadr caddr) count) ,list)
    817      call))
     871     `(car (nthcdr ,count ,list))))
    818872
    819873(define-compiler-macro nthcdr (&whole call &environment env count list)
     
    822876           (%i< count 4)) 
    823877     (if (%izerop count)
    824        list
     878       `(require-type ,list 'list)
    825879       `(,(svref '#(cdr cddr cdddr) (%i- count 1)) ,list))
    826      call))
     880    (let* ((i (gensym))
     881           (n (gensym))                 ; evaluation order
     882           (tail (gensym)))
     883      `(let* ((,n (require-type ,count 'unsigned-byte))
     884              (,tail (require-type ,list 'list)))
     885        (dotimes (,i ,n ,tail)
     886          (unless (setq ,tail (cdr ,tail))
     887            (return nil)))))))
    827888
    828889(define-compiler-macro plusp (x)
     
    18141875      `(float ,thing 0.0d0)
    18151876      call)))
    1816                      
     1877
     1878(define-compiler-macro equal (&whole call x y &environment env)
     1879  (if (or (equal-iff-eql-p x env)
     1880          (equal-iff-eql-p y env))
     1881    `(eql ,x ,y)
     1882    call))
    18171883
    18181884(provide "OPTIMIZERS")
Note: See TracChangeset for help on using the changeset viewer.