Changeset 7383 for branches/working-0710/ccl/compiler/optimizers.lisp
- Timestamp:
- Oct 12, 2007, 9:19:01 AM (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/working-0710/ccl/compiler/optimizers.lisp
r6473 r7383 135 135 t)) 136 136 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) 150 141 (destructuring-bind (&key (test nil test-p) 151 142 (test-not nil test-not-p) 152 143 (key nil key-p)) 153 144 keys 154 (declare (ignore test-not key))145 (declare (ignore test-not)) 155 146 (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))) 158 155 (consp test) 159 156 (consp (%cdr test)) … … 161 158 (or (eq (%car test) 'function) 162 159 (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 170 166 171 167 (defun eql-iff-eq-p (thing env) … … 174 170 (if (not (self-evaluating-p thing)) 175 171 (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))))) 181 179 (or (fixnump thing) #+64-bit-target (typep thing 'single-float) 180 (symbolp thing) (characterp thing) 182 181 (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 183 192 184 193 (defun fold-constant-subforms (call env) … … 330 339 331 340 332 (define-compiler-macro assoc (&whole call &environment envitem 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) 334 343 call)) 335 344 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)))))) 336 369 337 370 (define-compiler-macro caar (form) … … 785 818 (setq ,temp-var (setf (cdr ,temp-var) (list (funcall ,fn-var ,elt-var))))))))) 786 819 787 (define-compiler-macro member (&whole call &environment envitem 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) 789 822 call)) 790 823 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 791 840 (define-compiler-macro memq (&whole call &environment env item list) 792 793 794 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... 795 844 (if (and (or (quoted-form-p list) 796 845 (null list)) 797 846 (null (cdr (%cadr list)))) 798 847 (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)))))) 800 854 801 855 (define-compiler-macro minusp (x) … … 815 869 (%i< count 3)) 816 870 `(,(svref '#(car cadr caddr) count) ,list) 817 call))871 `(car (nthcdr ,count ,list)))) 818 872 819 873 (define-compiler-macro nthcdr (&whole call &environment env count list) … … 822 876 (%i< count 4)) 823 877 (if (%izerop count) 824 list878 `(require-type ,list 'list) 825 879 `(,(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))))))) 827 888 828 889 (define-compiler-macro plusp (x) … … 1814 1875 `(float ,thing 0.0d0) 1815 1876 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)) 1817 1883 1818 1884 (provide "OPTIMIZERS")
Note: See TracChangeset
for help on using the changeset viewer.