Changeset 9389
- Timestamp:
- May 7, 2008, 3:12:45 PM (17 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/working-0711/ccl/compiler/optimizers.lisp
r9363 r9389 2 2 ;;; 3 3 ;;; Copyright (C) 1994-2001 Digitool, Inc 4 ;;; This file is part of OpenMCL. 4 ;;; This file is part of OpenMCL. 5 5 ;;; 6 6 ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public … … 8 8 ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, 9 9 ;;; which is distributed with OpenMCL as the file "LGPL". Where these 10 ;;; conflict, the preamble takes precedence. 10 ;;; conflict, the preamble takes precedence. 11 11 ;;; 12 12 ;;; OpenMCL is referenced in the preamble as the "LIBRARY." … … 58 58 (let* ((bits (%symbol-bits name))) 59 59 (declare (fixnum bits)) 60 (%symbol-bits name (logior 60 (%symbol-bits name (logior 61 61 (if handler (logior (ash 1 $sym_fbit_fold_subforms) (ash 1 $sym_fbit_constant_fold)) 62 62 (ash 1 $sym_fbit_constant_fold)) … … 118 118 (push arg targs) 119 119 (return))) 120 (return 120 (return 121 121 (fixnumify (nreverse targs) op)))) 122 122 call)) … … 144 144 keys 145 145 (declare (ignore test-not)) 146 (if (and test-p 146 (if (and test-p 147 147 (not test-not-p) 148 148 (or (not key-p) … … 153 153 (eq (%car key) 'quote)) 154 154 (eq (%cadr key) 'identity))) 155 (consp test) 155 (consp test) 156 156 (consp (%cdr test)) 157 157 (null (%cddr test)) … … 203 203 (let* ((op (car call)) 204 204 (constant (if (cdr constants) (handler-case (apply op constants) 205 (error (c) (declare (ignore c)) 205 (error (c) (declare (ignore c)) 206 206 (return-from fold-constant-subforms (values call t)))) 207 207 (car constants)))) … … 256 256 ;;; 257 257 ;;; The new (roughly alphabetical) order. 258 ;;; 258 ;;; 259 259 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 260 260 … … 302 302 `(+ ,x 1)) 303 303 304 (define-compiler-macro append (&whole call 305 &optional arg0 306 &rest 307 (&whole tail 308 &optional (junk nil arg1-p) 304 (define-compiler-macro append (&whole call 305 &optional arg0 306 &rest 307 (&whole tail 308 &optional (junk nil arg1-p) 309 309 &rest more)) 310 310 ;(append (list x y z) A) -> (list* x y z A) … … 338 338 (apply (class-cell-instantiate ,class-cell) ,class-cell ,@args))) 339 339 (let ((original-fn fn)) 340 (if (and arg0 340 (if (and arg0 341 341 (null args) 342 342 (consp fn) … … 368 368 `(asseql ,item ,list) 369 369 call)) 370 370 371 371 (define-compiler-macro asseql (&whole call &environment env item list) 372 372 (if (or (eql-iff-eq-p item env) … … 424 424 (define-compiler-macro caaaar (form) 425 425 `(car (caaar ,form))) 426 426 427 427 (define-compiler-macro caaadr (form) 428 428 `(car (caadr ,form))) … … 448 448 (define-compiler-macro cdaaar (form) 449 449 `(cdr (caaar ,form))) 450 450 451 451 (define-compiler-macro cdaadr (form) 452 452 `(cdr (caadr ,form))) … … 492 492 call)) 493 493 494 (define-compiler-macro dotimes (&whole call (i n &optional result) 494 (define-compiler-macro dotimes (&whole call (i n &optional result) 495 495 &body body 496 496 &environment env) … … 545 545 (multiple-value-bind (test test-win) (nx-transform test env) 546 546 (if (or (quoted-form-p test) (self-evaluating-p test)) 547 (if (eval test) 547 (if (eval test) 548 548 true 549 549 false) … … 559 559 call))) 560 560 561 (defun string-designator-p (object) 562 (typecase object 563 (character t) 564 (symbol t) 565 (string t))) 566 567 (defun package-designator-p (object) 568 (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)) 561 576 562 577 (define-compiler-macro ldb (&whole call &environment env byte integer) … … 679 694 (type-specifier ctype))) 680 695 681 682 696 697 683 698 (define-compiler-macro make-array (&whole call &environment env dims &rest keys) 684 699 (if (constant-keywords-p keys) … … 689 704 (fill-pointer () fill-pointer-p) 690 705 (initial-element () initial-element-p) 691 (initial-contents () initial-contents-p)) 706 (initial-contents () initial-contents-p)) 692 707 keys 693 708 (declare (ignorable element-type element-type-p … … 699 714 initial-contents initial-contents-p)) 700 715 (let* ((element-type-keyword nil) 701 (expansion 716 (expansion 702 717 (cond ((and initial-element-p initial-contents-p) 703 718 (nx1-whine 'illegal-arguments call) … … 707 722 (comp-make-array-1 dims keys) 708 723 (comp-make-displaced-array dims keys))) 709 ((or displaced-index-offset-p 724 ((or displaced-index-offset-p 710 725 (not (constantp element-type)) 711 726 (null (setq element-type-keyword … … 713 728 (eval element-type) env)))) 714 729 (comp-make-array-1 dims keys)) 715 ((and (typep element-type-keyword 'keyword) 716 (nx-form-typep dims 'fixnum env) 717 (null (or adjustable fill-pointer initial-contents 718 initial-contents-p))) 719 (if 720 (or (null initial-element-p) 721 (cond ((eql element-type-keyword :double-float-vector) 722 (eql initial-element 0.0d0)) 723 ((eql element-type-keyword :single-float-vector) 724 (eql initial-element 0.0s0)) 725 ((eql element-type :simple-string) 730 ((and (typep element-type-keyword 'keyword) 731 (nx-form-typep dims 'fixnum env) 732 (null (or adjustable fill-pointer initial-contents 733 initial-contents-p))) 734 (if 735 (or (null initial-element-p) 736 (cond ((eql element-type-keyword :double-float-vector) 737 (eql initial-element 0.0d0)) 738 ((eql element-type-keyword :single-float-vector) 739 (eql initial-element 0.0s0)) 740 ((eql element-type :simple-string) 726 741 (eql initial-element #\Null)) 727 742 (t (eql initial-element 0)))) 728 `(allocate-typed-vector ,element-type-keyword ,dims) 729 `(allocate-typed-vector ,element-type-keyword ,dims ,initial-element))) 743 `(allocate-typed-vector ,element-type-keyword ,dims) 744 `(allocate-typed-vector ,element-type-keyword ,dims ,initial-element))) 730 745 (t ;Should do more here 731 746 (comp-make-uarray dims keys (type-keyword-code element-type-keyword))))) 732 747 (type (infer-array-type dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env))) 733 748 `(the ,type ,expansion))) 734 749 735 750 call)) 736 751 … … 767 782 (let* ((call-list (make-list 10 :initial-element nil)) 768 783 (dims-var (make-symbol "DIMS")) 769 (let-list (comp-nuke-keys keys 784 (let-list (comp-nuke-keys keys 770 785 '((:element-type 0 1) 771 786 (:displaced-to 2) … … 813 828 814 829 815 830 816 831 817 832 (define-compiler-macro mapc (&whole call fn lst &rest more) … … 853 868 `(memeql ,item ,list) 854 869 call)) 855 870 856 871 (define-compiler-macro memeql (&whole call &environment env item list) 857 872 (if (or (eql-iff-eq-p item env) … … 898 913 (if (and (fixnump count) 899 914 (%i>= count 0) 900 (%i< count 4)) 915 (%i< count 4)) 901 916 (if (%izerop count) 902 917 `(require-type ,list 'list) … … 949 964 ((type= ctype 950 965 (specifier-type '(signed-byte 8))) 951 `(the (signed-byte 8) (require-s8 ,arg))) 966 `(the (signed-byte 8) (require-s8 ,arg))) 952 967 ((type= ctype 953 968 (specifier-type '(unsigned-byte 8))) … … 958 973 ((type= ctype 959 974 (specifier-type '(unsigned-byte 16))) 960 `(the (unsigned-byte 16) (require-u16 ,arg))) 975 `(the (unsigned-byte 16) (require-u16 ,arg))) 961 976 ((type= ctype 962 977 (specifier-type '(signed-byte 32))) … … 1168 1183 (dolist (,elt-var ,sequence (%cdr ,result-var)) 1169 1184 (,loop-test (funcall ,test (funcall ,key ,elt-var)) 1170 (setq ,temp-var 1171 (%cdr 1185 (setq ,temp-var 1186 (%cdr 1172 1187 (%rplacd ,temp-var (list ,elt-var))))))))) 1173 1188 call)) … … 1288 1303 `(not (logbitp 0 (the fixnum ,n0))) 1289 1304 w)) 1290 1305 1291 1306 1292 1307 (define-compiler-macro logandc2 (n0 n1) … … 1328 1343 `(require-type ,n0 'integer) 1329 1344 identity))))))) 1330 1345 1331 1346 (define-compiler-macro logand (&whole w &rest all) 1332 1347 (declare (ignore all)) … … 1351 1366 `(not (eql 0 (logand ,n1 ,n2))) 1352 1367 w)) 1353 1368 1354 1369 1355 1370 (defmacro defsynonym (from to) … … 1358 1373 (setf (compiler-macro-function ',from) nil) 1359 1374 (let ((pair (assq ',from *nx-synonyms*))) 1360 (if pair (rplacd pair ',to) 1361 (push (cons ',from ',to) 1375 (if pair (rplacd pair ',to) 1376 (push (cons ',from ',to) 1362 1377 *nx-synonyms*)) 1363 1378 ',to))) … … 1486 1501 `(array-%%typep ,thing ,ctype)))))) 1487 1502 1488 1489 1503 1504 1490 1505 (defun optimize-typep (thing type env) 1491 1506 ;; returns a new form, or nil if it can't optimize … … 1514 1529 (t nil))) 1515 1530 ((consp type) 1516 (cond 1531 (cond 1517 1532 ((info-type-builtin type) ; byte types 1518 1533 `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type)))) 1519 (t 1534 (t 1520 1535 (case (%car type) 1521 1536 (satisfies `(funcall ',(cadr type) ,thing)) … … 1689 1704 1690 1705 1691 1706 1692 1707 (defsynonym %get-unsigned-byte %get-byte) 1693 1708 (defsynonym %get-unsigned-word %get-word) … … 1796 1811 (type (if ctype (type-specifier (array-ctype-specialized-element-type ctype)))) 1797 1812 (useful (unless (or (eq type *) (eq type t)) 1798 type))) 1813 type))) 1799 1814 (if (= 2 (length subscripts)) 1800 1815 (setq call `(%aref2 ,a ,@subscripts)) … … 1893 1908 1894 1909 1895 (define-compiler-macro integerp (thing) 1910 (define-compiler-macro integerp (thing) 1896 1911 (let* ((typecode (gensym)) 1897 1912 (fixnum-tag (arch::target-fixnum-tag (backend-target-arch *target-backend*))) … … 1929 1944 (ash 1 x8664::subtag-double-float) 1930 1945 (ash 1 x8664::subtag-ratio)))))))) 1931 1946 1932 1947 (define-compiler-macro %composite-pointer-ref (size pointer offset) 1933 1948 (if (constantp size) … … 2029 2044 2030 2045 (define-compiler-macro float (&whole call number &optional (other 0.0f0 other-p) &environment env) 2031 2046 2032 2047 (cond ((and (typep other 'single-float) 2033 2048 (nx-form-typep number 'double-float env)) … … 2106 2121 (and (integerp ,val) (not (< ,val 0))))))) 2107 2122 2108 2109 2110 2123 (provide "OPTIMIZERS") 2111 2112 2113 2114 2115 2116 2117
Note:
See TracChangeset
for help on using the changeset viewer.
