returns (1 2 3) instead of signalling an error. This was fixed by
APD's "more strict type checking patch", but although the fixed
code (in sbcl-0.7.7.19) works (signals TYPE-ERROR) interactively,
- it's difficult to write a regression test for it, because
+ it's difficult to write a regression test for it, because
(IGNORE-ERRORS (MULTIPLE-VALUE-PROG1 (PROGN (THE REAL '(1 2 3)))))
still returns (1 2 3).
- still-broken parts:
- b. (IGNORE-ERRORS (MULTIPLE-VALUE-PROG1 (PROGN (THE REAL '(1 2 3)))))
+ still-broken parts:
+ b. (IGNORE-ERRORS (MULTIPLE-VALUE-PROG1 (PROGN (THE REAL '(1 2 3)))))
returns (1 2 3). (As above, this shows up when writing regression
tests for fixed-ness of part a.)
c. Also in sbcl-0.7.7.9, (IGNORE-ERRORS (THE REAL '(1 2 3))) => (1 2 3).
29-bit pseudorandom numbers?
208: "package confusion in PCL handling of structure slot handlers"
- In sbcl-0.7.8 compiling and loading
+ In sbcl-0.7.8 compiling and loading
(in-package :cl)
(defstruct foo (slot (error "missing")) :type list :read-only t)
(defmethod print-object ((foo foo) stream) (print nil stream))
; in: LAMBDA NIL
; (FOO :Y 1 :Y 2)
- ;
+ ;
; caught STYLE-WARNING:
; The variable #:G15 is defined but never used.
given an error instead (ANSI 17.1.1 allows this behaviour on the part
of the implementation, as conforming code cannot give non-proper
sequences to these functions. MAP also has this problem (and
- solution), though arguably the convenience of being able to do
- (MAP 'LIST '+ FOO '#1=(1 . #1#))
+ solution), though arguably the convenience of being able to do
+ (MAP 'LIST '+ FOO '#1=(1 . #1#))
might be classed as more important (though signalling an error when
all of the arguments are circular is probably desireable).
213: "Sequence functions and type checking"
a. MAKE-SEQUENCE, COERCE, MERGE and CONCATENATE cannot deal with
- various complicated, though recognizeable, CONS types [e.g.
+ various complicated, though recognizeable, CONS types [e.g.
(CONS * (CONS * NULL))
which according to ANSI should be recognized] (and, in SAFETY 3
code, should return a list of LENGTH 2 or signal an error)
(CONS INTEGER *)
whether or not the return value is of this type. This is
probably permitted by ANSI (see "Exceptional Situations" under
- ANSI MAKE-SEQUENCE), but the DERIVE-TYPE mechanism does not
+ ANSI MAKE-SEQUENCE), but the DERIVE-TYPE mechanism does not
know about this escape clause, so code of the form
(INTEGERP (CAR (MAKE-SEQUENCE '(CONS INTEGER *) 2)))
can erroneously return T.
219: "DEFINE-COMPILER-MACRO in non-toplevel contexts evaluated at compile-time"
In sbcl-0.7.9:
- * (defun foo (x)
+ * (defun foo (x)
(when x
(define-compiler-macro bar (&whole whole)
(declare (ignore whole))
* (baz t)
1
-220:
+220:
Sbcl 0.7.9 fails to compile
(multiple-value-call #'list
(apply bar0 rest)
(format t "~&back from BAR~%"))))
(bar 12)
- recurses endlessly in sbcl-0.7.9.32. (Or it works if #' and
+ recurses endlessly in sbcl-0.7.9.32. (Or it works if #' and
FDEFINITION are replaced by SYMBOL-FUNCTION.)
+224:
+ SBCL 0.7.8 fails to compile
+
+ (localy (declare (optimize (safety 3)))
+ (ignore-errors (progn (values-list (car (list '(1 . 2)))) t)))
+
+225:
+ As reported by Gilbert Baumann on free-clim mailing list 2002-11-11,
+ there is no class STRING-STREAM.
+
DEFUNCT CATEGORIES OF BUGS
IR1-#:
These labels were used for bugs related to the old IR1 interpreter.
"DEFENUM"
"DEFPRINTER"
"AVER" "ENFORCE-TYPE"
+ "AWHEN" "ACOND" "IT"
;; ..and CONDITIONs..
"BUG"
;; hash caches
"DEFINE-HASH-CACHE"
"DEFUN-CACHED"
+ "DEFINE-CACHED-SYNONYM"
;; time
"FORMAT-DECODED-TIME"
,@(values-names))
(values ,@(values-names)))
(values ,@(values-names))))))))))))
+
+(defmacro define-cached-synonym
+ (name &optional (original (symbolicate "%" name)))
+ (let ((cached-name (symbolicate "%%" name "-cached")))
+ `(progn
+ (defun-cached (,cached-name :hash-bits 8
+ :hash-function (lambda (x)
+ (logand (sxhash x) #xff)))
+ ((args equal))
+ (apply #',original args))
+ (defun ,name (&rest args)
+ (,cached-name args)))))
+
\f
;;;; package idioms
(warn "using deprecated ~S~@[, should use ~S instead~]"
bad-name
good-name))
+
+;;; Anaphoric macros
+(defmacro awhen (test &body body)
+ `(let ((it ,test))
+ (when it ,@body)))
+
+(defmacro acond (&rest clauses)
+ (if (null clauses)
+ `()
+ (destructuring-bind ((test &body body) &rest rest) clauses
+ (once-only ((test test))
+ `(if ,test
+ (let ((it ,test)) (declare (ignorable it)),@body)
+ (acond ,@rest))))))
(defstruct (values-type
(:include args-type
(class-info (type-class-or-lose 'values)))
+ (:constructor %make-values-type)
(:copier nil)))
+(define-cached-synonym make-values-type)
(!define-type-class values)
;;; things such as SIMPLE-STRING.
(defstruct (array-type (:include ctype
(class-info (type-class-or-lose 'array)))
+ (:constructor %make-array-type)
(:copier nil))
;; the dimensions of the array, or * if unspecified. If a dimension
;; is unspecified, it is *.
(element-type (missing-arg) :type ctype)
;; the element type as it is specialized in this implementation
(specialized-element-type *wild-type* :type ctype))
+(define-cached-synonym make-array-type)
;;; A MEMBER-TYPE represent a use of the MEMBER type specifier. We
;;; bother with this at this level because MEMBER types are fairly
(class-info (type-class-or-lose 'union)))
(:constructor %make-union-type (enumerable types))
(:copier nil)))
+(define-cached-synonym make-union-type)
;;; An INTERSECTION-TYPE represents a use of the AND type specifier
;;; which we couldn't canonicalize to something simpler. Canonical form:
(logand (sxhash x) #x3FF))
:hash-bits 10
:init-wrapper !cold-init-forms)
- ((orig eq))
+ ((orig equal))
(let ((u (uncross orig)))
(or (info :type :builtin u)
(let ((spec (type-expand u)))
res))
(!def-type-translator values (&rest values)
- (let ((res (make-values-type)))
+ (let ((res (%make-values-type)))
(parse-args-types values res)
res))
\f
(defun args-type-op (type1 type2 operation nreq default-type)
(declare (type ctype type1 type2 default-type)
(type function operation nreq))
+ (when (eq type1 type2)
+ (values type1 t))
(if (or (values-type-p type1) (values-type-p type2))
(let ((type1 (coerce-to-values type1))
(type2 (coerce-to-values type2)))
nil)))
(defun type-intersection (&rest input-types)
+ (%type-intersection input-types))
+(defun-cached (%type-intersection :hash-bits 8
+ :hash-function (lambda (x)
+ (logand (sxhash x) #xff)))
+ ((input-types equal))
(let ((simplified-types (simplified-compound-types input-types
#'intersection-type-p
#'type-intersection2)))
*universal-type*))))
(defun type-union (&rest input-types)
+ (%type-union input-types))
+(defun-cached (%type-union :hash-bits 8
+ :hash-function (lambda (x)
+ (logand (sxhash x) #xff)))
+ ((input-types equal))
(let ((simplified-types (simplified-compound-types input-types
#'union-type-p
#'type-union2)))
- (make-compound-type-or-something #'%make-union-type
+ (make-compound-type-or-something #'make-union-type
simplified-types
(every #'type-enumerable simplified-types)
*empty-type*)))
*empty-type*))))))
(!define-type-method (member :complex-intersection2) (type1 type2)
- (block punt
+ (block punt
(collect ((members))
(let ((mem2 (member-type-members type2)))
(dolist (member mem2)
(dimensions '*))
(specialize-array-type
(make-array-type :dimensions (canonical-array-dimensions dimensions)
+ :complexp :maybe
:element-type (specifier-type element-type))))
(!def-type-translator simple-array (&optional (element-type '*)
(dimensions '*))
(specialize-array-type
(make-array-type :dimensions (canonical-array-dimensions dimensions)
- :element-type (specifier-type element-type)
- :complexp nil)))
+ :complexp nil
+ :element-type (specifier-type element-type))))
\f
;;;; utilities shared between cross-compiler and target system
(defun assert-new-value-type (new-value array)
(let ((type (continuation-type array)))
(when (array-type-p type)
- (assert-continuation-type new-value
- (array-type-specialized-element-type type))))
+ (assert-continuation-type
+ new-value
+ (array-type-specialized-element-type type)
+ (lexenv-policy (node-lexenv (continuation-dest new-value))))))
(continuation-type new-value))
(defun assert-array-complex (array)
- (assert-continuation-type array
- (make-array-type :complexp t
- :element-type *wild-type*)))
+ (assert-continuation-type
+ array
+ (make-array-type :complexp t
+ :element-type *wild-type*)
+ (lexenv-policy (node-lexenv (continuation-dest array)))))
;;; Return true if ARG is NIL, or is a constant-continuation whose
;;; value is NIL, false otherwise.
(defun assert-array-rank (array rank)
(assert-continuation-type
array
- (specifier-type `(array * ,(make-list rank :initial-element '*)))))
+ (specifier-type `(array * ,(make-list rank :initial-element '*)))
+ (lexenv-policy (node-lexenv (continuation-dest array)))))
(defoptimizer (array-in-bounds-p derive-type) ((array &rest indices))
(assert-array-rank array (length indices))
;; If the node continuation has a single use then assert its type.
(let ((cont (node-cont node)))
(when (= (length (find-uses cont)) 1)
- (assert-continuation-type cont (extract-upgraded-element-type array))))
+ (assert-continuation-type cont (extract-upgraded-element-type array)
+ (lexenv-policy (node-lexenv node)))))
(extract-upgraded-element-type array))
(defoptimizer (%aset derive-type) ((array &rest stuff))
(type-test-cost (cons-type-cdr-type type))))
(t
(fun-guessed-cost 'typep)))))
+
+(defun-cached
+ (weaken-type :hash-bits 8
+ :hash-function (lambda (x)
+ (logand (type-hash-value x) #xFF)))
+ ((type eq))
+ (declare (type ctype type))
+ (let ((min-cost (type-test-cost type))
+ (min-type type)
+ (found-super nil))
+ (dolist (x *backend-type-predicates*)
+ (let ((stype (car x)))
+ (when (and (csubtypep type stype)
+ (not (union-type-p stype)))
+ (let ((stype-cost (type-test-cost stype)))
+ (when (or (< stype-cost min-cost)
+ (type= stype type))
+ ;; If the supertype is equal in cost to the type, we
+ ;; prefer the supertype. This produces a closer
+ ;; approximation of the right thing in the presence of
+ ;; poor cost info.
+ (setq found-super t
+ min-type stype
+ min-cost stype-cost))))))
+ (if found-super
+ min-type
+ *universal-type*)))
+
+(defun weaken-values-type (type)
+ (declare (type ctype type))
+ (cond ((eq type *wild-type*) type)
+ ((values-type-p type)
+ (make-values-type :required (mapcar #'weaken-type
+ (values-type-required type))
+ :optional (mapcar #'weaken-type
+ (values-type-optional type))
+ :rest (acond ((values-type-rest type)
+ (weaken-type it))
+ ((values-type-keyp type)
+ *universal-type*))))
+ (t (weaken-type type))))
\f
;;;; checking strategy determination
;;; than safety, then we return a weaker type if it is easier to
;;; check. First we try the defined type weakenings, then look for any
;;; predicate that is cheaper.
-;;;
-;;; If the supertype is equal in cost to the type, we prefer the
-;;; supertype. This produces a closer approximation of the right thing
-;;; in the presence of poor cost info.
-(defun maybe-weaken-check (type cont)
- (declare (type ctype type) (type continuation cont))
- (cond ((policy (continuation-dest cont)
+(defun maybe-weaken-check (type policy)
+ (declare (type ctype type))
+ (cond ((policy policy (zerop safety))
+ *wild-type*)
+ ((policy policy
(and (<= speed safety)
(<= space safety)
(<= compilation-speed safety)))
type)
(t
- (let ((min-cost (type-test-cost type))
- (min-type type)
- (found-super nil))
- (dolist (x *backend-type-predicates*)
- (let ((stype (car x)))
- (when (and (csubtypep type stype)
- (not (union-type-p stype)))
- (let ((stype-cost (type-test-cost stype)))
- (when (or (< stype-cost min-cost)
- (type= stype type))
- (setq found-super t
- min-type stype
- min-cost stype-cost))))))
- (if found-super
- min-type
- *universal-type*)))))
+ (weaken-values-type type))))
;;; This is like VALUES-TYPES, only we mash any complex function types
;;; to FUNCTION.
;;; FIXME: I don't quite understand this, but it looks as though
;;; that means type checks are weakened when SPEED=3 regardless of
;;; the SAFETY level, which is not the right thing to do.
-(defun maybe-negate-check (cont types force-hairy)
+(defun maybe-negate-check (cont types original-types force-hairy)
(declare (type continuation cont) (list types))
(multiple-value-bind (ptypes count)
(no-fun-values-types (continuation-proven-type cont))
(if (eq count :unknown)
- (if (and (every #'type-check-template types) (not force-hairy))
- (values :simple types)
- (values :hairy
- (mapcar (lambda (x)
- (list nil (maybe-weaken-check x cont) x))
- types)))
- (let ((res (mapcar (lambda (p c)
- (let ((diff (type-difference p c))
- (weak (maybe-weaken-check c cont)))
- (if (and diff
- (< (type-test-cost diff)
- (type-test-cost weak))
- *complement-type-checks*)
- (list t diff c)
- (list nil weak c))))
- ptypes types)))
- (cond ((or force-hairy (find-if #'first res))
- (values :hairy res))
- ((every #'type-check-template types)
- (values :simple types))
- ((policy (continuation-dest cont)
- (or (<= debug 1) (and (= speed 3) (/= debug 3))))
- (let ((weakened (mapcar #'second res)))
- (if (every #'type-check-template weakened)
- (values :simple weakened)
- (values :hairy res))))
- (t
- (values :hairy res)))))))
+ (if (and (every #'type-check-template types) (not force-hairy))
+ (values :simple types)
+ (values :hairy (mapcar (lambda (x) (list nil x x)) types)))
+ (let ((res (mapcar (lambda (p c a)
+ (let ((diff (type-difference p c)))
+ (if (and diff
+ (< (type-test-cost diff)
+ (type-test-cost c))
+ *complement-type-checks*)
+ (list t diff a)
+ (list nil c a))))
+ ptypes types original-types)))
+ (cond ((or force-hairy (find-if #'first res))
+ (values :hairy res))
+ ((every #'type-check-template types)
+ (values :simple types))
+ (t
+ (values :hairy res)))))))
;;; Determines whether CONT's assertion is:
;;; -- checkable by the back end (:SIMPLE), or
;;; consideration. If it is cheaper to test for the difference between
;;; the derived type and the asserted type, then we check for the
;;; negation of this type instead.
-(defun continuation-check-types (cont)
+(defun continuation-check-types (cont force-hairy)
(declare (type continuation cont))
- (let ((type (continuation-asserted-type cont))
+ (let ((ctype (continuation-type-to-check cont))
+ (atype (continuation-asserted-type cont))
(dest (continuation-dest cont)))
- (aver (not (eq type *wild-type*)))
- (multiple-value-bind (types count) (no-fun-values-types type)
- (cond ((not (eq count :unknown))
- (if (or (exit-p dest)
- (and (return-p dest)
- (multiple-value-bind (ignore count)
- (values-types (return-result-type dest))
- (declare (ignore ignore))
- (eq count :unknown))))
- (maybe-negate-check cont types t)
- (maybe-negate-check cont types nil)))
- ((and (mv-combination-p dest)
- (eq (basic-combination-kind dest) :local))
- (aver (values-type-p type))
- (maybe-negate-check cont (args-type-optional type) nil))
- (t
- (values :too-hairy nil))))))
+ (aver (not (eq ctype *wild-type*)))
+ (multiple-value-bind (ctypes count) (no-fun-values-types ctype)
+ (multiple-value-bind (atypes acount) (no-fun-values-types ctype)
+ (aver (eq count acount))
+ (cond ((not (eq count :unknown))
+ (if (or (exit-p dest)
+ (and (return-p dest)
+ (multiple-value-bind (ignore count)
+ (values-types (return-result-type dest))
+ (declare (ignore ignore))
+ (eq count :unknown))))
+ (maybe-negate-check cont ctypes atypes t)
+ (maybe-negate-check cont ctypes atypes force-hairy)))
+ ((and (mv-combination-p dest)
+ (eq (basic-combination-kind dest) :local))
+ (aver (values-type-p ctype))
+ (maybe-negate-check cont
+ (args-type-optional ctype)
+ (args-type-optional atype)
+ force-hairy))
+ (t
+ (values :too-hairy nil)))))))
+
+;;; Do we want to do a type check?
+(defun worth-type-check-p (cont)
+ (let ((dest (continuation-dest cont)))
+ (not (or (values-subtypep (continuation-proven-type cont)
+ (continuation-type-to-check cont))
+ (and (combination-p dest)
+ (eq (combination-kind dest) :full)
+ ;; The theory is that the type assertion is from a
+ ;; declaration in (or on) the callee, so the callee
+ ;; should be able to do the check. We want to let
+ ;; the callee do the check, because it is possible
+ ;; that by the time of call that declaration will be
+ ;; changed and we do not want to make people
+ ;; recompile all calls to a function when they were
+ ;; originally compiled with a bad declaration. (See
+ ;; also bug 35.)
+ (values-subtypep (continuation-externally-checkable-type cont)
+ (continuation-type-to-check cont)))
+ (and (mv-combination-p dest) ; bug 220
+ (eq (mv-combination-kind dest) :full))))))
;;; Return true if CONT is a continuation whose type the back end is
;;; likely to want to check. Since we don't know what template the
(let ((kind (basic-combination-kind dest)))
(cond ((eq cont (basic-combination-fun dest)) t)
((eq kind :local) t)
- ((mv-combination-p dest)
- ;; See bug 220
- nil)
- ((not (eq (continuation-asserted-type cont)
- (continuation-externally-checkable-type cont)))
- ;; There is an explicit assertion.
- t)
((eq kind :full)
- ;; The theory is that the type assertion is from a
- ;; declaration in (or on) the callee, so the
- ;; callee should be able to do the check. We want
- ;; to let the callee do the check, because it is
- ;; possible that by the time of call that
- ;; declaration will be changed and we do not want
- ;; to make people recompile all calls to a
- ;; function when they were originally compiled
- ;; with a bad declaration. (See also bug 35.)
- nil)
+ (and (combination-p dest)
+ (not (values-subtypep ; explicit THE
+ (continuation-externally-checkable-type cont)
+ (continuation-type-to-check cont)))))
((eq kind :error) nil)
;; :ERROR means that we have an invalid syntax of
(unless (policy node (= inhibit-warnings 3))
(emit-type-warning use))))))
(when (eq type-check t)
- (cond ((probable-type-check-p cont)
- (conts cont))
- (t
- (setf (continuation-%type-check cont) :no-check))))))
+ (cond ((worth-type-check-p cont)
+ (conts (cons cont (not (probable-type-check-p cont)))))
+ ((probable-type-check-p cont)
+ (setf (continuation-%type-check cont) :deleted))
+ (t
+ (setf (continuation-%type-check cont) :no-check))))))
(setf (block-type-check block) nil)))
(dolist (cont (conts))
- (multiple-value-bind (check types) (continuation-check-types cont)
- (ecase check
- (:simple)
- (:hairy
- (convert-type-check cont types))
- (:too-hairy
- (let* ((context (continuation-dest cont))
- (*compiler-error-context* context))
- (when (policy context (>= safety inhibit-warnings))
- (compiler-note
- "type assertion too complex to check:~% ~S."
- (type-specifier (continuation-asserted-type cont)))))
- (setf (continuation-%type-check cont) :deleted))))))
+ (destructuring-bind (cont . force-hairy) cont
+ (multiple-value-bind (check types)
+ (continuation-check-types cont force-hairy)
+ (ecase check
+ (:simple)
+ (:hairy
+ (convert-type-check cont types))
+ (:too-hairy
+ (let* ((context (continuation-dest cont))
+ (*compiler-error-context* context))
+ (when (policy context (>= safety inhibit-warnings))
+ (compiler-note
+ "type assertion too complex to check:~% ~S."
+ (type-specifier (continuation-asserted-type cont)))))
+ (setf (continuation-%type-check cont) :deleted)))))))
(values))
((not really-assert) t)
(t
(when atype
- (assert-continuation-type (return-result return) atype))
+ (assert-continuation-type (return-result return) atype
+ (lexenv-policy (functional-lexenv functional))))
(loop for var in vars and type in types do
(cond ((basic-var-sets var)
(when (and unwinnage-fun
:unwinnage-fun #'compiler-note
:where "proclamation"))))
\f
-;;;;
+;;;; FIXME: Move to some other file.
(defun check-catch-tag-type (tag)
(declare (type continuation tag))
(let ((ctype (continuation-type tag)))
(def-ir1-translator %funcall ((function &rest args) start cont)
(let ((fun-cont (make-continuation)))
(ir1-convert start fun-cont function)
- (assert-continuation-type fun-cont (specifier-type 'function))
+ (assert-continuation-type fun-cont (specifier-type 'function)
+ (lexenv-policy *lexenv*))
(ir1-convert-combination-args fun-cont cont args)))
;;; This source transform exists to reduce the amount of work for the
;;; many branches there are going to be.
(defun ir1ize-the-or-values (type cont lexenv place)
(declare (type continuation cont) (type lexenv lexenv))
- (let* ((ctype (if (typep type 'ctype) type (compiler-values-specifier-type type)))
- (old-type (or (lexenv-find cont type-restrictions)
- *wild-type*))
- (intersects (values-types-equal-or-intersect old-type ctype))
- (new (values-type-intersection old-type ctype)))
+ (let* ((atype (if (typep type 'ctype) type (compiler-values-specifier-type type)))
+ (old-atype (or (lexenv-find cont type-restrictions)
+ *wild-type*))
+ (old-ctype (or (lexenv-find cont weakend-type-restrictions)
+ *wild-type*))
+ (intersects (values-types-equal-or-intersect old-atype atype))
+ (new-atype (values-type-intersection old-atype atype))
+ (new-ctype (values-type-intersection
+ old-ctype (maybe-weaken-check atype (lexenv-policy lexenv)))))
(when (null (find-uses cont))
- (setf (continuation-asserted-type cont) new))
+ (setf (continuation-asserted-type cont) new-atype)
+ (setf (continuation-type-to-check cont) new-ctype))
(when (and (not intersects)
;; FIXME: Is it really right to look at *LEXENV* here,
;; instead of looking at the LEXENV argument? Why?
(= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
(compiler-warn
"The type ~S ~A conflicts with an enclosing assertion:~% ~S"
- (type-specifier ctype)
+ (type-specifier atype)
place
- (type-specifier old-type)))
- (make-lexenv :type-restrictions `((,cont . ,new))
+ (type-specifier old-atype)))
+ (make-lexenv :type-restrictions `((,cont . ,new-atype))
+ :weakend-type-restrictions `((,cont . ,new-ctype))
:default lexenv)))
;;; Assert that FORM evaluates to the specified type (which may be a
(defun setq-var (start cont var value)
(declare (type continuation start cont) (type basic-var var))
(let ((dest (make-continuation)))
- (setf (continuation-asserted-type dest) (leaf-type var))
+ (assert-continuation-type dest (leaf-type var) (lexenv-policy *lexenv*))
(ir1-convert start dest value)
(let ((res (make-set :var var :value dest)))
(setf (continuation-dest dest) res)
`(%coerce-callable-to-fun ,fun)))
(setf (continuation-dest fun-cont) node)
(assert-continuation-type fun-cont
- (specifier-type '(or function symbol)))
+ (specifier-type '(or function symbol))
+ (lexenv-policy *lexenv*))
(collect ((arg-conts))
(let ((this-start fun-cont))
(dolist (arg args)
(ir1-convert start dummy-start result)
(with-continuation-type-assertion
+ ;; FIXME: policy
(cont (continuation-asserted-type dummy-start)
"of the first form")
(substitute-continuation-uses cont dummy-start))
;; FUN-TYPE might be (AND FUNCTION (SATISFIES ...)).
(fun-type-wild-args fun-type))
(progn (dolist (arg args)
- (setf (continuation-%externally-checkable-type arg)
- *wild-type*))
+ (when arg
+ (setf (continuation-%externally-checkable-type arg)
+ *wild-type*)))
*wild-type*)
(let* ((arg-types (append (fun-type-required fun-type)
(fun-type-optional fun-type)
(loop
for arg of-type continuation in args
and type of-type ctype in arg-types
- do (setf (continuation-%externally-checkable-type arg)
- type))
+ do (when arg
+ (setf (continuation-%externally-checkable-type arg)
+ type)))
(continuation-%externally-checkable-type cont)))))))
\f
;;;; interface routines used by optimizers
(setf (block-type-check (node-block node)) t)))
(values))
-;;; Annotate Node to indicate that its result has been proven to be
-;;; typep to RType. After IR1 conversion has happened, this is the
+;;; Annotate NODE to indicate that its result has been proven to be
+;;; TYPEP to RTYPE. After IR1 conversion has happened, this is the
;;; only correct way to supply information discovered about a node's
-;;; type. If you screw with the Node-Derived-Type directly, then
+;;; type. If you screw with the NODE-DERIVED-TYPE directly, then
;;; information may be lost and reoptimization may not happen.
;;;
-;;; What we do is intersect Rtype with Node's Derived-Type. If the
+;;; What we do is intersect RTYPE with NODE's DERIVED-TYPE. If the
;;; intersection is different from the old type, then we do a
-;;; Reoptimize-Continuation on the Node-Cont.
+;;; REOPTIMIZE-CONTINUATION on the NODE-CONT.
(defun derive-node-type (node rtype)
(declare (type node node) (type ctype rtype))
(let ((node-type (node-derived-type node)))
(reoptimize-continuation (node-cont node))))))
(values))
+(defun set-continuation-type-assertion (cont atype ctype)
+ (declare (type continuation cont) (type ctype atype ctype))
+ (when (eq atype *wild-type*)
+ (return-from set-continuation-type-assertion))
+ (let* ((old-atype (continuation-asserted-type cont))
+ (old-ctype (continuation-type-to-check cont))
+ (new-atype (values-type-intersection old-atype atype))
+ (new-ctype (values-type-intersection old-ctype ctype)))
+ (when (or (type/= old-atype new-atype)
+ (type/= old-ctype new-ctype))
+ (setf (continuation-asserted-type cont) new-atype)
+ (setf (continuation-type-to-check cont) new-ctype)
+ (do-uses (node cont)
+ (setf (block-attributep (block-flags (node-block node))
+ type-check type-asserted)
+ t))
+ (reoptimize-continuation cont)))
+ (values))
+
;;; This is similar to DERIVE-NODE-TYPE, but asserts that it is an
;;; error for CONT's value not to be TYPEP to TYPE. If we improve the
;;; assertion, we set TYPE-CHECK and TYPE-ASSERTED to guarantee that
;;; the new assertion will be checked.
-(defun assert-continuation-type (cont type)
+(defun assert-continuation-type (cont type policy)
(declare (type continuation cont) (type ctype type))
- (let ((cont-type (continuation-asserted-type cont)))
- (unless (eq cont-type type)
- (let ((int (values-type-intersection cont-type type)))
- (when (type/= cont-type int)
- (setf (continuation-asserted-type cont) int)
- (do-uses (node cont)
- (setf (block-attributep (block-flags (node-block node))
- type-check type-asserted)
- t))
- (reoptimize-continuation cont)))))
- (values))
+ (when (eq type *wild-type*)
+ (return-from assert-continuation-type))
+ (set-continuation-type-assertion cont type (maybe-weaken-check type policy)))
;;; Assert that CALL is to a function of the specified TYPE. It is
;;; assumed that the call is legal and has only constants in the
(defun assert-call-type (call type)
(declare (type combination call) (type fun-type type))
(derive-node-type call (fun-type-returns type))
- (let ((args (combination-args call)))
+ (let ((args (combination-args call))
+ (policy (lexenv-policy (node-lexenv call))))
(dolist (req (fun-type-required type))
(when (null args) (return-from assert-call-type))
(let ((arg (pop args)))
- (assert-continuation-type arg req)))
+ (assert-continuation-type arg req policy)))
(dolist (opt (fun-type-optional type))
(when (null args) (return-from assert-call-type))
(let ((arg (pop args)))
- (assert-continuation-type arg opt)))
+ (assert-continuation-type arg opt policy)))
(let ((rest (fun-type-rest type)))
(when rest
(dolist (arg args)
- (assert-continuation-type arg rest))))
+ (assert-continuation-type arg rest policy))))
(dolist (key (fun-type-keywords type))
(let ((name (key-info-name key)))
((null arg))
(when (eq (continuation-value (first arg)) name)
(assert-continuation-type
- (second arg) (key-info-type key)))))))
+ (second arg) (key-info-type key)
+ policy))))))
(values))
\f
;;;; IR1-OPTIMIZE
(let* ((ref (first (leaf-refs var)))
(cont (node-cont ref))
(cont-atype (continuation-asserted-type cont))
+ (cont-ctype (continuation-type-to-check cont))
(dest (continuation-dest cont)))
(when (and (eq (continuation-use cont) ref)
dest
(lexenv-policy (node-lexenv (continuation-dest arg)))))
(aver (member (continuation-kind arg)
'(:block-start :deleted-block-start :inside-block)))
- (assert-continuation-type arg cont-atype)
+ (set-continuation-type-assertion arg cont-atype cont-ctype)
(setf (node-derived-type ref) *wild-type*)
(change-ref-leaf ref (find-constant nil))
(substitute-continuation arg cont)
(push node-block (block-pred block))
(add-continuation-use node cont)
(unless (eq (continuation-asserted-type cont) *wild-type*)
- (let ((new (values-type-union (continuation-asserted-type cont)
- (or (lexenv-find cont type-restrictions)
- *wild-type*))))
- (when (type/= new (continuation-asserted-type cont))
- (setf (continuation-asserted-type cont) new)
+ (let* ((restriction (or (lexenv-find cont type-restrictions)
+ *wild-type*))
+ (wrestriction (or (lexenv-find cont weakend-type-restrictions)
+ *wild-type*))
+ (newatype (values-type-union (continuation-asserted-type cont)
+ restriction))
+ (newctype (values-type-union (continuation-type-to-check cont)
+ wrestriction)))
+ (when (or (type/= newatype (continuation-asserted-type cont))
+ (type/= newctype (continuation-type-to-check cont)))
+ (setf (continuation-asserted-type cont) newatype)
+ (setf (continuation-type-to-check cont) newctype)
(reoptimize-continuation cont))))))
\f
;;;; exported functions
(let ((node (make-combination fun-cont)))
(setf (continuation-dest fun-cont) node)
(assert-continuation-type fun-cont
- (specifier-type '(or function symbol)))
+ (specifier-type '(or function symbol))
+ (lexenv-policy *lexenv*))
(setf (continuation-%externally-checkable-type fun-cont) nil)
(collect ((arg-conts))
(let ((this-start fun-cont))
;;; slot values. Values for the alist slots are NCONCed to the
;;; beginning of the current value, rather than replacing it entirely.
(defun make-lexenv (&key (default *lexenv*)
- funs vars blocks tags type-restrictions
+ funs vars blocks tags
+ type-restrictions weakend-type-restrictions
(lambda (lexenv-lambda default))
(cleanup (lexenv-cleanup default))
(policy (lexenv-policy default)))
(frob blocks lexenv-blocks)
(frob tags lexenv-tags)
(frob type-restrictions lexenv-type-restrictions)
+ (frob weakend-type-restrictions lexenv-weakend-type-restrictions)
lambda cleanup policy)))
;;; Makes a LEXENV, suitable for using in a MACROLET introduced
nil
nil
(lexenv-type-restrictions lexenv) ; XXX
+ (lexenv-weakend-type-restrictions lexenv)
nil
nil
(lexenv-policy lexenv))))
(setf (continuation-next cont) nil)
(setf (continuation-asserted-type cont) *empty-type*)
(setf (continuation-%derived-type cont) *empty-type*)
+ (setf (continuation-type-to-check cont) *empty-type*)
(setf (continuation-use cont) nil)
(setf (continuation-block cont) nil)
(setf (continuation-reoptimize cont) nil)
(setf (node-derived-type inside) *wild-type*)
(flush-dest cont)
(setf (continuation-asserted-type cont) *wild-type*)
+ (setf (continuation-type-to-check cont) *wild-type*)
(values))))))
\f
;;;; leaf hackery
(cond ((and (eq (continuation-type-check cont) t)
(multiple-value-bind (check types)
- (continuation-check-types cont)
+ (continuation-check-types cont nil)
(aver (eq check :simple))
;; If the proven type is a subtype of the possibly
;; weakened type check then it's always true and is
(nlocs (length locs)))
(aver (= nlocs (length ptypes)))
(if (eq (continuation-type-check cont) t)
- (multiple-value-bind (check types) (continuation-check-types cont)
+ (multiple-value-bind (check types) (continuation-check-types cont nil)
(aver (eq check :simple))
(let ((ntypes (length types)))
(mapcar (lambda (from to-type assertion)
'(debug . 1)
'(inhibit-warnings . 1)))))
(:constructor internal-make-lexenv
- (funs vars blocks tags type-restrictions
+ (funs vars blocks tags
+ type-restrictions
+ weakend-type-restrictions
lambda cleanup policy)))
;; an alist of (NAME . WHAT), where WHAT is either a FUNCTIONAL (a
;; local function), a DEFINED-FUN, representing an
;; THING is a continuation, this is used to track the innermost THE
;; type declaration.
(type-restrictions nil :type list)
+ (weakend-type-restrictions nil :type list)
;; the lexically enclosing lambda, if any
;;
;; FIXME: This should be :TYPE (OR CLAMBDA NULL), but it was too hard
(let ((arg (car args))
(var (car vars)))
(cond ((leaf-refs var)
- (assert-continuation-type arg (leaf-type var)))
+ (assert-continuation-type arg (leaf-type var)
+ (lexenv-policy (node-lexenv call))))
(t
(flush-dest arg)
(setf (car args) nil)))))
(assert-continuation-type
(first (basic-combination-args call))
(make-values-type :optional (mapcar #'leaf-type (lambda-vars ep))
- :rest *universal-type*))))
+ :rest *universal-type*)
+ (lexenv-policy (node-lexenv call)))))
(values))
;;; Attempt to convert a call to a lambda. If the number of args is
(cont (node-cont call))
(call-type (node-derived-type call)))
(when (eq (continuation-use cont) call)
- (assert-continuation-type cont (continuation-asserted-type result)))
+ (set-continuation-type-assertion
+ cont
+ (continuation-asserted-type result)
+ (continuation-type-to-check result)))
(unless (eq call-type *wild-type*)
(do-uses (use result)
(derive-node-type use call-type)))
;; This is computed lazily by CONTINUATION-DERIVED-TYPE, so use
;; CONTINUATION-TYPE-CHECK instead of the %'ed slot accessor.
(%type-check t :type (member t nil :deleted :no-check))
+ ;; Asserted type, weakend according to policies
+ (type-to-check *wild-type* :type ctype)
;; Cached type which is checked by DEST. If NIL, then this must be
;; recomputed: see CONTINUATION-EXTERNALLY-CHECKABLE-TYPE.
(%externally-checkable-type nil :type (or null ctype))
;;; (fix provided by Matthew Danish) on sbcl-devel
(assert (null (ignore-errors
(defmacro bug172 (&rest rest foo) `(list ,rest ,foo)))))
+
+;;; embedded THEs
+(defun check-embedded-thes (policy1 policy2 x y)
+ (handler-case
+ (funcall (compile nil
+ `(lambda (f)
+ (declare (optimize (speed 2) (safety ,policy1)))
+ (multiple-value-list
+ (the (values (integer 2 3) t)
+ (locally (declare (optimize (safety ,policy2)))
+ (the (values t (single-float 2f0 3f0))
+ (funcall f)))))))
+ (lambda () (values x y)))
+ (type-error (error)
+ error)))
+
+(assert (equal (check-embedded-thes 0 0 :a :b) '(:a :b)))
+
+(assert (equal (check-embedded-thes 0 3 :a 2.5f0) '(:a 2.5f0)))
+(assert (typep (check-embedded-thes 0 3 2 3.5f0) 'type-error))
+
+(assert (equal (check-embedded-thes 0 1 :a 3.5f0) '(:a 3.5f0)))
+(assert (typep (check-embedded-thes 0 1 2 2.5d0) 'type-error))
+
+#+nil
+(assert (equal (check-embedded-thes 3 0 2 :a) '(2 :a)))
+(assert (typep (check-embedded-thes 3 0 4 2.5f0) 'type-error))
+
+(assert (equal (check-embedded-thes 1 0 4 :b) '(4 :b)))
+(assert (typep (check-embedded-thes 1 0 1.0 2.5f0) 'type-error))
+
+
+(assert (equal (check-embedded-thes 3 3 2 2.5f0) '(2 2.5f0)))
+(assert (typep (check-embedded-thes 3 3 0 2.5f0) 'type-error))
+(assert (typep (check-embedded-thes 3 3 2 3.5f0) 'type-error))
+
\f
;;;; tests not in the problem domain, but of the consistency of the
;;;; compiler machinery itself
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.9.40"
+"0.7.9.41"
projects / sbcl.git / commitdiff