Changeset 10008


Ignore:
Timestamp:
Jul 11, 2008, 10:01:25 AM (11 years ago)
Author:
gb
Message:

Lots of bugs (many long-standing) exposed by test suite; we're now
running it with a policy that allows compiler-macros to be used.

INFER-ARRAY-TYPE: in general, the best we can do for a non-constant
element-type is *, but that's better than treating non-constants
as type-specifiers.

CONSTANT-KEYWORDS-P does (as it apparently once did) need to check
for duplicates; we can't do destructuring over a list of keyword/
value pairs unless we're sure that there are no duplicates, since
the values associated with the duplicate keys might have side-effects.
(If we're sure that any such values are constants, we can allow them
as long as COMP-NUKE-KEYS does the right thing (e.g., uses the value
associated with the leftmost instance of the keyword.)

COMP-NUKE-KEYS: don't set positional arg in "call-list" if it has
already been set (e.g., if duplicate keywords, leftmost wins.)

If TYPEP transforms to a call to ARRAY-%%TYPEP, return just the first
value.

Character comparisons involving 3 args have to evaluate the third
form (for side-effects), even if the function result can be determined
by looking at the first 2 characters. (The way that this is done,
(char< #\b #\a 17) might signal an error when inlined and the function
may not, but that case is bogus, anyway.)

These bugs caused about 180 test failures; a few more tests (involving
bignum/float comparisons and RANDOM) still fail, but I haven't yet
been able to get them to fail in an environment where I can reproduce
the failure.

File:
1 edited

Legend:

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

    r9938 r10008  
    122122    call))
    123123
    124 ;;; True if arg is an alternating list of keywords and args,
    125 ;;; only recognizes keywords in keyword package.
    126 ;;; Historical note: this used to try to ensure that the
    127 ;;; keyword appeared at most once.  Why ? (Even before
    128 ;;; destructuring, pl-search/getf would have dtrt.)
     124;;; True if arg is an alternating list of keywords and args, only
     125;;; recognizes keywords in keyword package.  Historical note: this
     126;;; used to try to ensure that the keyword appeared at most once.  Why
     127;;; ? (Even before destructuring, pl-search/getf would have dtrt.)
     128;;; Side effects: it's not the right thing to simply pick the value
     129;;; associated with the first occurrence of a keyword if the value
     130;;; associated with subsequent occurrence could have a side-effect.
     131;;; (We -can- ignore a duplicate key if the associated value is
     132;;; side-effect free.)
    129133(defun constant-keywords-p (keys)
    130134  (when (plistp keys)
    131     (while keys
    132       (unless (keywordp (%car keys))
    133         (return-from constant-keywords-p nil))
    134       (setq keys (%cddr keys)))
    135     t))
     135    (do* ((seen ())
     136          (keys keys (cddr keys)))
     137         ((null keys) t)
     138      (let* ((key (car keys)))
     139        (if (or (not (keywordp key))
     140                (and (memq key seen)
     141                     (not (constantp (cadr keys)))))
     142          (return))
     143        (push key seen)))))
     144
    136145
    137146(defun remove-explicit-test-keyword-from-test-testnot-key (item list keys default alist testonly)
     
    686695          (setf (array-ctype-dimensions ctype)
    687696                '*))))
    688     (let* ((typespec (if element-type-p (nx-unquote element-type) t))
     697    (let* ((typespec (if element-type-p
     698                       (if (constantp element-type)
     699                         (nx-unquote element-type)
     700                         '*)
     701                       t))
    689702           (element-type (or (specifier-type-if-known typespec env)
    690703                             (make-unknown-ctype :specifier typespec))))
    691704      (setf (array-ctype-element-type ctype) element-type)
    692705      (if (typep element-type 'unknown-ctype)
    693         (setf (array-ctype-specialized-element-type ctype) *wild-type*)
    694         (specialize-array-type ctype)))
     706        (setf (array-ctype-element-type ctype) *wild-type*))
     707      (specialize-array-type ctype))
    695708    (type-specifier ctype)))
    696709
     
    770783    (let* ((call-list (make-list 6))
    771784           (dims-var (make-symbol "DIMS"))
    772          (let-list (comp-nuke-keys keys
    773                                    '((:adjustable 0)
    774                                      (:fill-pointer 1)
    775                                      (:initial-element 2 3)
    776                                      (:initial-contents 4 5))
    777                                    call-list
    778                                    `((,dims-var ,dims)))))
    779     `(let ,let-list
    780        (make-uarray-1 ,subtype ,dims-var ,@call-list nil nil)))))
     785           (let-list (comp-nuke-keys keys
     786                                     '((:adjustable 0)
     787                                       (:fill-pointer 1)
     788                                       (:initial-element 2 3)
     789                                       (:initial-contents 4 5))
     790                                     call-list
     791                                     `((,dims-var ,dims)))))
     792      `(let ,let-list
     793        (make-uarray-1 ,subtype ,dims-var ,@call-list nil nil)))))
    781794
    782795(defun comp-make-array-1 (dims keys)
     
    798811(defun comp-nuke-keys (keys key-list call-list &optional required-bindings)
    799812  ; side effects call list, returns a let-list
    800   (let ((let-list (reverse required-bindings)))
     813  (let* ((let-list (reverse required-bindings))
     814         (seen nil))
    801815    (do ((lst keys (cddr lst)))
    802816        ((null lst) nil)
     
    807821             (ppos (caddr ass)))
    808822        (when ass
    809           (when (not (constantp val))
    810             (let ((gen (gensym)))
    811               (setq let-list (cons (list gen val) let-list)) ; reverse him
    812               (setq val gen)))
    813           (rplaca (nthcdr vpos call-list) val)
    814           (if ppos (rplaca (nthcdr ppos call-list) t)))))
     823          (unless (memq vpos seen)
     824            (push vpos seen)
     825            (when (not (constantp val))
     826              (let ((gen (gensym)))
     827                (setq let-list (cons (list gen val) let-list)) ; reverse him
     828                (setq val gen)))
     829            (rplaca (nthcdr vpos call-list) val)
     830            (if ppos (rplaca (nthcdr ppos call-list) t))))))
    815831    (nreverse let-list)))
    816832
     
    15001516                          ,@(unless (eq (car dims) '*)
    15011517                                    `((eq (%svref ,temp target::vectorH.logsize-cell) ,(car dims)))))))))))))
    1502         `(array-%%typep ,thing ,ctype))))))
     1518        `(values (array-%%typep ,thing ,ctype)))))))
    15031519
    15041520
     
    20112027         (gtype (gensym)))
    20122028    `(let* ((,gthing ,thing)
    2013             (,gtype (typecode ,thing)))
     2029            (,gtype (typecode ,gthing)))
    20142030      (declare (type (unsigned-byte 8) ,gtype))
    20152031      (if (= ,gtype ,(nx-lookup-target-uvector-subtag :vector-header))
     
    20842100    (if (null (cdr others))
    20852101      (let* ((third (car others))
    2086              (code (gensym)))
    2087         `(let* ((,code (char-code ,ch)))
    2088           (and (eq ,code (setq ,code (char-code ,other)))
    2089            (eq ,code (char-code ,third)))))
     2102             (code (gensym))
     2103             (code2 (gensym))
     2104             (code3 (gensym)))
     2105        `(let* ((,code (char-code ,ch))
     2106                (,code2 (char-code ,other))
     2107                (,code3 (char-code ,third)))
     2108          (and (eq ,code ,code2)
     2109           (eq ,code2 ,code3))))
    20902110      call)))
    20912111
     
    20972117    (if (null (cdr others))
    20982118      (let* ((third (car others))
    2099              (code (gensym)))
    2100         `(let* ((,code (%char-code-upcase (char-code ,ch))))
    2101           (and (eq ,code (setq ,code (%char-code-upcase (char-code ,other))))
    2102            (eq ,code (%char-code-upcase (char-code ,third))))))
     2119             (code (gensym))
     2120             (code2 (gensym))
     2121             (code3 (gensym)))
     2122        `(let* ((,code (%char-code-upcase (char-code ,ch)))
     2123                (,code2 (%char-code-upcase (char-code ,other)))
     2124                (,code3 (%char-code-upcase (char-code ,third))))
     2125          (and (eq ,code ,code2)
     2126           (eq ,code ,code3))))
    21032127      call)))
    21042128
     
    21182142    (if (null (cdr others))
    21192143      (let* ((third (car others))
    2120              (code (gensym)))
    2121         `(let* ((,code (char-code ,ch)))
    2122           (declare (fixnum ,code))
    2123           (and (< ,code (setq ,code (char-code ,other)))
    2124            (< ,code (the fixnum (char-code ,third))))))
     2144             (code (gensym))
     2145             (code2 (gensym))
     2146             (code3 (gensym)))
     2147        ;; We have to evaluate all forms for side-effects.
     2148        ;; Hopefully, there won't be any
     2149        `(let* ((,code (char-code ,ch))
     2150                (,code2 (char-code ,other))
     2151                (,code3 (char-code ,third)))
     2152          (declare (fixnum ,code ,code2 ,code3))
     2153          (and (< ,code ,code2)
     2154           (< ,code2 ,code3))))
    21252155      call)))
    21262156
     
    21322162    (if (null (cdr others))
    21332163      (let* ((third (car others))
    2134              (code (gensym)))
    2135         `(let* ((,code (char-code ,ch)))
    2136           (declare (fixnum ,code))
    2137           (and (<= ,code (setq ,code (char-code ,other)))
    2138            (<= ,code (the fixnum (char-code ,third))))))
     2164             (code (gensym))
     2165             (code2 (gensym))
     2166             (code3 (gensym)))
     2167        `(let* ((,code (char-code ,ch))
     2168                (,code2 (char-code ,other))
     2169                (,code3 (char-code ,third)))
     2170          (declare (fixnum ,code ,code2 ,code3))
     2171          (and (<= ,code ,code2)
     2172           (<= ,code2 ,code3))))
    21392173      call)))
    21402174
     
    21462180    (if (null (cdr others))
    21472181      (let* ((third (car others))
    2148              (code (gensym)))
    2149         `(let* ((,code (char-code ,ch)))
    2150           (declare (fixnum ,code))
    2151           (and (> ,code (setq ,code (char-code ,other)))
    2152            (> ,code (the fixnum (char-code ,third))))))
     2182             (code (gensym))
     2183             (code2 (gensym))
     2184             (code3 (gensym)))
     2185        `(let* ((,code (char-code ,ch))
     2186                (,code2 (char-code ,other))
     2187                (,code3 (char-code ,third)))
     2188          (declare (fixnum ,code ,code2 code3))
     2189          (and (> ,code ,code2)
     2190           (> ,code2 ,code3))))
    21532191      call)))
    21542192
     
    21602198    (if (null (cdr others))
    21612199      (let* ((third (car others))
    2162              (code (gensym)))
    2163         `(let* ((,code (char-code ,ch)))
    2164           (declare (fixnum ,code))
    2165           (and (>= ,code (setq ,code (char-code ,other)))
    2166            (>= ,code (the fixnum (char-code ,third))))))
     2200             (code (gensym))
     2201             (code2 (gensym))
     2202             (code3 (gensym)))
     2203        `(let* ((,code (char-code ,ch))
     2204                (,code2 (char-code ,other))
     2205                (,code3 (char-code ,third)))
     2206          (declare (fixnum ,code ,code2 ,code3))
     2207          (and (>= ,code ,code2)
     2208           (>= ,code2 ,code3))))
    21672209      call)))
    21682210
Note: See TracChangeset for help on using the changeset viewer.