Merged CAST branch.
Changes since -cast.8:
* separated usage of object and values types;
* fixed warning and error reports for compile-time type
errors;
* inline structure slot accessors are implemented with source
transforms;
* enabled warning emitting for type errors in some paths to
CAST;
* removed check for type errors in arguments of a call of a
flushable function;
* source transforms are made nameless.
an error may be signalled at read time and it would be good if
SBCL did it.
- c: Reading of not initialized slot sometimes causes SEGV.
+ c: Reading of not initialized slot sometimes causes SEGV (for inline
+ accessors it is fixed, but out-of-line still do not perform type
+ check).
d:
(declaim (optimize (safety 3) (speed 1) (space 1)))
c. the examples in CLHS 7.6.5.1 (regarding generic function lambda
lists and &KEY arguments) do not signal errors when they should.
-192: "Python treats free type declarations as promises."
- b. What seemed like the same fundamental problem as bug 192a, but
- was not fixed by the same (APD "more strict type checking
- sbcl-devel 2002-08-97) patch:
- (DOTIMES (I ...) (DOTIMES (J ...) (DECLARE ...) ...)):
- (declaim (optimize (speed 1) (safety 3)))
- (defun trust-assertion (i)
- (dotimes (j i)
- (declare (type (mod 4) i)) ; when commented out, behavior changes!
- (unless (< i 5)
- (print j))))
- (trust-assertion 6) ; prints nothing unless DECLARE is commented out
-
- (see bug 203)
-
- c. (defun foo (x y)
- (locally (declare (type fixnum x y))
- (+ x (* 2 y))))
- (foo 1.1 2) => 5.1
-
-194: "no error from (THE REAL '(1 2 3)) in some cases"
- fixed parts:
- a. In sbcl-0.7.7.9,
- (multiple-value-prog1 (progn (the real '(1 2 3))))
- 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
- (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)))))
- 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).
- d. At the REPL,
- (null (ignore-errors
- (let ((arg1 1)
- (arg2 (identity (the real #(1 2 3)))))
- (if (< arg1 arg2) arg1 arg2))))
- => T
- but putting the same expression inside (DEFUN FOO () ...),
- (FOO) => NIL.
- notes:
- * Actually this entry is probably multiple bugs, as
- Alexey Dejneka commented on sbcl-devel 2002-09-03:)
- I don't think that placing these two bugs in one entry is
- a good idea: they have different explanations. The second
- (min 1 nil) is caused by flushing of unused code--IDENTITY
- can do nothing with it. So it is really bug 122. The first
- (min nil) is due to M-V-PROG1: substituting a continuation
- for the result, it forgets about type assertion. The purpose
- of IDENTITY is to save the restricted continuation from
- inaccurate transformations.
- * Alexey Dejneka pointed out that
- (IGNORE-ERRORS (IDENTITY (THE REAL '(1 2 3))))
- and
- (IGNORE-ERRORS (VALUES (THE REAL '(1 2 3))))
- work as they should.
201: "Incautious type inference from compound CONS types"
(reported by APD sbcl-devel 2002-09-17)
(FOO ' (1 . 2)) => "NIL IS INTEGER, Y = 1"
-203:
- Compiler does not check THEs on unused values, e.g. in
-
- (progn (the real (list 1)) t)
-
- This situation may appear during optimizing away degenerate cases of
- certain functions: see bug 192b.
-
205: "environment issues in cross compiler"
(These bugs have no impact on user code, but should be fixed or
documented.)
Without (DECLARE (NOTINLINE MAPCAR)), Python cannot derive that Z is
LIST.
-236: "THE semantics is broken"
-
- (defun foo (a f)
- (declare (optimize (speed 2) (safety 0)))
- (+ 1d0
- (the double-float
- (multiple-value-prog1
- (svref a 0)
- (unless f (return-from foo 0))))))
-
- (foo #(4) nil) => SEGV
-
- VOP selection thinks that in unsafe code result type assertions
- should be valid immediately. (See also bug 233a.)
-
- The similar problem exists for TRULY-THE.
-
237: "Environment arguments to type functions"
a. Functions SUBTYPEP, TYPEP, UPGRADED-ARRAY-ELEMENT-TYPE, and
UPGRADED-COMPLEX-PART-TYPE now have an optional environment
(TYPEP 1 '(SYMBOL NIL)) says something about "unknown type
specifier".
+249:
+ Local functions do not check types of unused arguments:
+ (defun foo (x)
+ (flet ((bar (y)
+ (declare (fixnum y))
+ (incf x)))
+ (list (bar x) (bar x) (bar x))))
+ (foo 1.0) => (2.0 3.0 4.0)
+
+250:
+ (make-array nil :initial-element 11) causes a warning.
+
+251:
+ (defun foo (&key (a :x))
+ (declare (fixnum a))
+ a)
+
+ does not cause a warning. (BTW: old SBCL issued a warning, but for a
+ function, which was never called!)
+
DEFUNCT CATEGORIES OF BUGS
IR1-#:
These labels were used for bugs related to the old IR1 interpreter.
* bug fix: make.sh and friends are now more consistent in the way that
they for GNU "make".
+changes in sbcl-0.8.1 relative to sbcl-0.8.0:
+ * changes in type checking closed the following bugs:
+ ** type checking of unused values (192b, 194d, 203);
+ ** template selection based on unsafe type assertions (192c, 236);
+ ** type checking in branches (194bc).
+ * VALUES declaration is disabled.
+
planned incompatible changes in 0.8.x:
* (not done yet, but planned:) When the profiling interface settles
down, it might impact TRACE. They both encapsulate functions, and
"SC-OFFSET-OFFSET" "SC-OFFSET-SCN" "SC-OR-LOSE" "SC-P" "SC-SB"
"SET-UNWIND-PROTECT" "SET-VECTOR-SUBTYPE"
"SETUP-CLOSURE-ENVIRONMENT" "SETUP-ENVIRONMENT"
- "SPECIFY-SAVE-TN" "INSTANCE-REF"
- "INSTANCE-SET" "TAIL-CALL" "TAIL-CALL-NAMED"
+ "SOURCE-TRANSFORM-LAMBDA"
+ "SPECIFY-SAVE-TN"
+ "TAIL-CALL" "TAIL-CALL-NAMED"
"TAIL-CALL-VARIABLE" "TEMPLATE-OR-LOSE"
"TN" "TN-OFFSET" "TN-P" "TN-REF" "TN-REF-ACROSS" "TN-REF-LOAD-TN"
"TN-REF-NEXT" "TN-REF-NEXT-REF" "TN-REF-P" "TN-REF-TARGET"
;; miscellaneous non-standard but handy user-level functions..
"ASSQ" "DELQ" "MEMQ" "POSQ" "NEQ"
+ "ADJUST-LIST"
"%FIND-PACKAGE-OR-LOSE" "FIND-UNDELETED-PACKAGE-OR-LOSE"
"SANE-PACKAGE"
"CYCLIC-LIST-P"
"COMPOUND-OBJECT-P"
"SWAPPED-ARGS-FUN"
- "AND/TYPE"
+ "AND/TYPE" "NOT/TYPE"
"ANY/TYPE" "EVERY/TYPE"
"EQUAL-BUT-NO-CAR-RECURSION"
"TYPE-BOUND-NUMBER"
"INDEX" "LOAD/STORE-INDEX"
"SIGNED-BYTE-WITH-A-BITE-OUT"
"UNSIGNED-BYTE-WITH-A-BITE-OUT"
+ "SFUNCTION"
;; ..and type predicates
"INSTANCEP"
"DOUBLE-FLOAT-P"
"PROPER-LIST-OF-LENGTH-P"
"LIST-OF-LENGTH-AT-LEAST-P"
"LIST-WITH-LENGTH-P"
+ "SINGLETON-P"
"READ-SEQUENCE-OR-DIE"
"RENAME-KEY-ARGS"
"MISSING-ARG"
"CODE-DEBUG-INFO" "CODE-HEADER-REF" "CODE-HEADER-SET"
"CODE-INSTRUCTIONS"
"COERCE-TO-FUN" "COERCE-TO-LEXENV"
- "COERCE-TO-LIST" "COERCE-TO-VECTOR"
+ "COERCE-TO-LIST" "COERCE-TO-VALUES"
+ "COERCE-TO-VECTOR"
"*COLD-INIT-COMPLETE-P*"
"COMPLEX-DOUBLE-FLOAT-P"
"COMPLEX-FLOAT-P"
"MAKE-SINGLE-FLOAT" "MAKE-SPECIALIZABLE-ARRAY"
"MAKE-UNPORTABLE-FLOAT"
"%MAKE-INSTANCE"
+ "MAKE-SHORT-VALUES-TYPE"
+ "MAKE-SINGLE-VALUE-TYPE"
"MAKE-VALUE-CELL"
"MAKE-VALUES-TYPE"
"MEMBER-TYPE" "MEMBER-TYPE-MEMBERS"
"TYPE-DIFFERENCE" "TYPE-EXPAND"
"TYPE-INTERSECTION" "TYPE-INTERSECTION2"
"TYPE-APPROX-INTERSECTION2"
+ "TYPE-SINGLE-VALUE-P"
"TYPE-SPECIFIER" "TYPE-UNION" "TYPE/=" "TYPE="
"TYPES-EQUAL-OR-INTERSECT"
"UNBOUND-SYMBOL-ERROR" "UNBOXED-ARRAY"
"VALUES-SPECIFIER-TYPE"
"VALUES-SPECIFIER-TYPE-CACHE-CLEAR" "VALUES-SUBTYPEP"
"VALUES-TYPE"
- "VALUES-TYPE-INTERSECTION" "VALUES-TYPE-KEYP"
- "VALUES-TYPE-KEYWORDS" "VALUES-TYPE-OPTIONAL"
+ "VALUES-TYPE-ERROR"
+ "VALUES-TYPE-INTERSECTION"
+ "VALUES-TYPE-OPTIONAL"
"VALUES-TYPE-P" "VALUES-TYPE-REQUIRED"
"VALUES-TYPE-REST" "VALUES-TYPE-UNION"
- "VALUES-TYPES" "VALUES-TYPES-EQUAL-OR-INTERSECT" "VECTOR-T-P"
+ "VALUES-TYPE-TYPES" "VALUES-TYPES"
+ "VALUES-TYPE-START"
+ "VALUES-TYPES-EQUAL-OR-INTERSECT" "VECTOR-T-P"
"VECTOR-TO-VECTOR*"
"VECTOR-OF-CHECKED-LENGTH-GIVEN-LENGTH"
"WITH-ARRAY-DATA"
;;;; setup of CONDITION machinery, only because that makes it easier to
;;;; get cold init to work.
+(define-condition values-type-error (type-error)
+ ()
+ (:report
+ (lambda (condition stream)
+ (format stream
+ "~@<The values set ~2I~:_[~{~S~^ ~}] ~I~_is not of type ~2I~_~S.~:>"
+ (type-error-datum condition)
+ (type-error-expected-type condition)))))
+
;;; KLUDGE: a condition for floating point errors when we can't or
;;; won't figure out what type they are. (In FreeBSD and OpenBSD we
;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably
`(,raw-slot-accessor (,ref ,instance-name ,(dd-raw-index dd))
,scaled-dsd-index))))))
-;;; Return inline expansion designators (i.e. values suitable for
-;;; (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR ..)) for the reader
-;;; and writer functions of the slot described by DSD.
-(defun slot-accessor-inline-expansion-designators (dd dsd)
- (let ((instance-type-decl `(declare (type ,(dd-name dd) instance)))
- (accessor-place-form (%accessor-place-form dd dsd 'instance))
+;;; Return source transforms for the reader and writer functions of
+;;; the slot described by DSD. They should be inline expanded, but
+;;; source transforms work faster.
+(defun slot-accessor-transforms (dd dsd)
+ (let ((accessor-place-form (%accessor-place-form dd dsd
+ `(the ,(dd-name dd) instance)))
(dsd-type (dsd-type dsd))
(value-the (if (dsd-safe-p dsd) 'truly-the 'the)))
- (values (lambda () `(lambda (instance)
- ,instance-type-decl
- (,value-the ,dsd-type ,accessor-place-form)))
- (lambda () `(lambda (new-value instance)
- (declare (type ,dsd-type new-value))
- ,instance-type-decl
- (setf ,accessor-place-form new-value))))))
+ (values (sb!c:source-transform-lambda (instance)
+ `(,value-the ,dsd-type ,(subst instance 'instance
+ accessor-place-form)))
+ (sb!c:source-transform-lambda (new-value instance)
+ (destructuring-bind (accessor-name &rest accessor-args)
+ accessor-place-form
+ `(,(info :setf :inverse accessor-name)
+ ,@(subst instance 'instance accessor-args)
+ (the ,dsd-type ,new-value)))))))
;;; Return a LAMBDA form which can be used to set a slot.
(defun slot-setter-lambda-form (dd dsd)
- (funcall (nth-value 1
- (slot-accessor-inline-expansion-designators dd dsd))))
+ `(lambda (new-value instance)
+ ,(funcall (nth-value 1 (slot-accessor-transforms dd dsd))
+ '(dummy new-value instance))))
;;; core compile-time setup of any class with a LAYOUT, used even by
;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities
(let ((copier-name (dd-copier-name dd)))
(when copier-name
- (sb!xc:proclaim `(ftype (function (,dtype) ,dtype) ,copier-name))))
+ (sb!xc:proclaim `(ftype (sfunction (,dtype) ,dtype) ,copier-name))))
(let ((predicate-name (dd-predicate-name dd)))
(when predicate-name
- (sb!xc:proclaim `(ftype (function (t) t) ,predicate-name))
+ (sb!xc:proclaim `(ftype (sfunction (t) t) ,predicate-name))
;; Provide inline expansion (or not).
(ecase (dd-type dd)
((structure funcallable-structure)
- ;; Let the predicate be inlined.
+ ;; Let the predicate be inlined.
(setf (info :function :inline-expansion-designator predicate-name)
(lambda ()
`(lambda (x)
(cond
((not inherited)
(multiple-value-bind (reader-designator writer-designator)
- (slot-accessor-inline-expansion-designators dd dsd)
- (sb!xc:proclaim `(ftype (function (,dtype) ,dsd-type)
+ (slot-accessor-transforms dd dsd)
+ (sb!xc:proclaim `(ftype (sfunction (,dtype) ,dsd-type)
,accessor-name))
- (setf (info :function :inline-expansion-designator
- accessor-name)
- reader-designator
- (info :function :inlinep accessor-name)
- :inline)
+ (setf (info :function :source-transform accessor-name)
+ reader-designator)
(unless (dsd-read-only dsd)
(let ((setf-accessor-name `(setf ,accessor-name)))
(sb!xc:proclaim
- `(ftype (function (,dsd-type ,dtype) ,dsd-type)
+ `(ftype (sfunction (,dsd-type ,dtype) ,dsd-type)
,setf-accessor-name))
- (setf (info :function
- :inline-expansion-designator
- setf-accessor-name)
- writer-designator
- (info :function :inlinep setf-accessor-name)
- :inline)))))
+ (setf (info :function :source-transform setf-accessor-name)
+ writer-designator)))))
((not (= (cdr inherited) (dsd-index dsd)))
(style-warn "~@<Non-overwritten accessor ~S does not access ~
slot with name ~S (accessing an inherited slot ~
(* max-offset sb!vm:n-word-bytes))
scale)))
+;;; Similar to FUNCTION, but the result type is "exactly" specified:
+;;; if it is an object type, then the function returns exactly one
+;;; value, if it is a short form of VALUES, then this short form
+;;; specifies the exact number of values.
+(def!type sfunction (args &optional result)
+ (let ((result (cond ((eq result '*) '*)
+ ((or (atom result)
+ (not (eq (car result) 'values)))
+ `(values ,result &optional))
+ ((intersection (cdr result) lambda-list-keywords)
+ result)
+ (t `(values ,@(cdr result) &optional)))))
+ `(function ,args ,result)))
+
;;; the default value used for initializing character data. The ANSI
;;; spec says this is arbitrary, so we use the value that falls
;;; through when we just let the low-level consing code initialize
(and (consp x)
(list-of-length-at-least-p (cdr x) (1- n)))))
+(declaim (inline singleton-p))
+(defun singleton-p (list)
+ (and (consp list)
+ (null (rest list))))
+
;;; Is X is a positive prime integer?
(defun positive-primep (x)
;; This happens to be called only from one place in sbcl-0.7.0, and
(declaim (ftype (function (list index) t) nth-but-with-sane-arg-order))
(defun nth-but-with-sane-arg-order (list index)
(nth index list))
+
+(defun adjust-list (list length initial-element)
+ (let ((old-length (length list)))
+ (cond ((< old-length length)
+ (append list (make-list (- length old-length)
+ :initial-element initial-element)))
+ ((> old-length length)
+ (subseq list 0 length))
+ (t list))))
\f
;;;; miscellaneous iteration extensions
-;;; "the ultimate iteration macro"
+;;; "the ultimate iteration macro"
;;;
;;; note for Schemers: This seems to be identical to Scheme's "named LET".
(defmacro named-let (name binds &body body)
\f
;;;; utilities for two-VALUES predicates
+(defmacro not/type (x)
+ (let ((val (gensym "VAL"))
+ (win (gensym "WIN")))
+ `(multiple-value-bind (,val ,win)
+ ,x
+ (if ,win
+ (values (not ,val) t)
+ (values nil nil)))))
+
(defmacro and/type (x y)
`(multiple-value-bind (val1 win1) ,x
(if (and (not val1) win1)
(allowp nil :type boolean))
(defun canonicalize-args-type-args (required optional rest)
- (when rest
- (let ((last-distinct-optional (position rest optional
- :from-end t
- :test-not #'type=)))
- (setf optional
- (when last-distinct-optional
- (subseq optional 0 (1+ last-distinct-optional))))))
- (values required optional rest))
+ (when (eq rest *empty-type*)
+ ;; or vice-versa?
+ (setq rest nil))
+ (loop with last-not-rest = nil
+ for i from 0
+ for opt in optional
+ do (cond ((eq opt *empty-type*)
+ (return (values required (subseq optional i) rest)))
+ ((neq opt rest)
+ (setq last-not-rest i)))
+ finally (return (values required
+ (if last-not-rest
+ (subseq optional 0 (1+ last-not-rest))
+ nil)
+ rest))))
(defun args-types (lambda-list-like-thing)
(multiple-value-bind
(multiple-value-bind (required optional rest)
(canonicalize-args-type-args required optional rest)
(values required optional rest keyp keywords allowp)))))
-
+
(defstruct (values-type
(:include args-type
(class-info (type-class-or-lose 'values)))
(:constructor %make-values-type)
(:copier nil)))
-(defun make-values-type (&rest initargs
- &key (args nil argsp) &allow-other-keys)
+(defun-cached (make-values-type-cached
+ :hash-bits 8
+ :hash-function (lambda (req opt rest allowp)
+ (logand (logxor
+ (type-list-cache-hash req)
+ (type-list-cache-hash opt)
+ (if rest
+ (type-hash-value rest)
+ 42)
+ (sxhash allowp))
+ #xFF)))
+ ((required equal-but-no-car-recursion)
+ (optional equal-but-no-car-recursion)
+ (rest eq)
+ (allowp eq))
+ (%make-values-type :required required
+ :optional optional
+ :rest rest
+ :allowp allowp))
+
+;;; FIXME: ANSI VALUES has a short form (without lambda list
+;;; keywords), which should be translated into a long one.
+(defun make-values-type (&key (args nil argsp)
+ required optional rest allowp)
(if argsp
(if (eq args '*)
*wild-type*
(multiple-value-bind (required optional rest keyp keywords allowp)
(args-types args)
- (if (and (null required)
- (null optional)
- (eq rest *universal-type*)
- (not keyp))
- *wild-type*
- (%make-values-type :required required
- :optional optional
- :rest rest
- :keyp keyp
- :keywords keywords
- :allowp allowp))))
- (apply #'%make-values-type initargs)))
+ (declare (ignore keywords))
+ (when keyp
+ (error "&KEY appeared in a VALUES type specifier ~S."
+ `(values ,@args)))
+ (make-values-type :required required
+ :optional optional
+ :rest rest
+ :allowp allowp)))
+ (multiple-value-bind (required optional rest)
+ (canonicalize-args-type-args required optional rest)
+ (cond ((and (null required)
+ (null optional)
+ (eq rest *universal-type*))
+ *wild-type*)
+ ((memq *empty-type* required)
+ *empty-type*)
+ (t (make-values-type-cached required optional
+ rest allowp))))))
(!define-type-class values)
;;; (SPECIFIER-TYPE 'FUNCTION) and its subtypes
(defstruct (fun-type (:include args-type
(class-info (type-class-or-lose 'function)))
- (:constructor %make-fun-type))
+ (:constructor %make-fun-type))
;; true if the arguments are unrestrictive, i.e. *
(wild-args nil :type boolean)
;; type describing the return values. This is a values type
:ELEMENT-TYPE - the type of object to read or write, default BASE-CHAR
:IF-EXISTS - one of :ERROR, :NEW-VERSION, :RENAME, :RENAME-AND-DELETE,
:OVERWRITE, :APPEND, :SUPERSEDE or NIL
- :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or nil
+ :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL
See the manual for details."
(unless (eq external-format :default)
(!define-type-method (values :simple-=) (type1 type2)
(let ((rest1 (args-type-rest type1))
(rest2 (args-type-rest type2)))
- (cond ((or (args-type-keyp type1) (args-type-keyp type2)
- (args-type-allowp type1) (args-type-allowp type2))
- (values nil nil))
- ((and rest1 rest2 (type/= rest1 rest2))
+ (cond ((and rest1 rest2 (type/= rest1 rest2))
(type= rest1 rest2))
((or rest1 rest2)
(values nil t))
(result)))
(!def-type-translator function (&optional (args '*) (result '*))
- (make-fun-type :args args :returns (values-specifier-type result)))
+ (make-fun-type :args args
+ :returns (coerce-to-values (values-specifier-type result))))
(!def-type-translator values (&rest values)
(make-values-type :args values))
;;;; We provide a few special operations that can be meaningfully used
;;;; on VALUES types (as well as on any other type).
+(defun type-single-value-p (type)
+ (and (values-type-p type)
+ (not (values-type-rest type))
+ (null (values-type-optional type))
+ (singleton-p (values-type-required type))))
+
;;; Return the type of the first value indicated by TYPE. This is used
;;; by people who don't want to have to deal with VALUES types.
#!-sb-fluid (declaim (freeze-type values-type))
; (inline single-value-type))
(defun single-value-type (type)
(declare (type ctype type))
- (cond ((values-type-p type)
- (or (car (args-type-required type))
- (if (args-type-optional type)
- (type-union (car (args-type-optional type))
- (specifier-type 'null)))
- (args-type-rest type)
- (specifier-type 'null)))
- ((eq type *wild-type*)
- *universal-type*)
- (t
- type)))
+ (cond ((eq type *wild-type*)
+ *universal-type*)
+ ((eq type *empty-type*)
+ *empty-type*)
+ ((not (values-type-p type))
+ type)
+ (t (or (car (args-type-required type))
+ (car (args-type-optional type))
+ (args-type-rest type)
+ (specifier-type 'null)))))
;;; Return the minimum number of arguments that a function can be
;;; called with, and the maximum number or NIL. If not a function
;;; not fixed, then return NIL and :UNKNOWN.
(defun values-types (type)
(declare (type ctype type))
- (cond ((eq type *wild-type*)
+ (cond ((or (eq type *wild-type*) (eq type *empty-type*))
(values nil :unknown))
- ((not (values-type-p type))
- (values (list type) 1))
((or (args-type-optional type)
- (args-type-rest type)
- (args-type-keyp type)
- (args-type-allowp type))
+ (args-type-rest type))
(values nil :unknown))
(t
(let ((req (args-type-required type)))
- (values (mapcar #'single-value-type req) (length req))))))
+ (values req (length req))))))
;;; Return two values:
;;; 1. A list of all the positional (fixed and optional) types.
-;;; 2. The &REST type (if any). If keywords allowed, *UNIVERSAL-TYPE*.
-;;; If no keywords or &REST, then the DEFAULT-TYPE.
+;;; 2. The &REST type (if any). If no &REST, then the DEFAULT-TYPE.
(defun values-type-types (type &optional (default-type *empty-type*))
- (declare (type values-type type))
- (values (append (args-type-required type)
- (args-type-optional type))
- (cond ((args-type-keyp type) *universal-type*)
- ((args-type-rest type))
- (t
- default-type))))
+ (declare (type ctype type))
+ (if (eq type *wild-type*)
+ (values nil *universal-type*)
+ (values (append (args-type-required type)
+ (args-type-optional type))
+ (cond ((args-type-rest type))
+ (t default-type)))))
+
+;;; If COUNT values are supplied, which types should they have?
+(defun values-type-start (type count)
+ (declare (ctype type) (unsigned-byte count))
+ (if (eq type *wild-type*)
+ (make-list count :initial-element *universal-type*)
+ (collect ((res))
+ (flet ((process-types (types)
+ (loop for type in types
+ while (plusp count)
+ do (decf count)
+ do (res type))))
+ (process-types (values-type-required type))
+ (process-types (values-type-optional type))
+ (when (plusp count)
+ (loop with rest = (the ctype (values-type-rest type))
+ repeat count
+ do (res rest))))
+ (res))))
;;; Return a list of OPERATION applied to the types in TYPES1 and
;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter
:initial-element rest2)))
exact)))
-;;; If TYPE isn't a values type, then make it into one:
-;;; <type> ==> (values type &rest t)
+;;; If TYPE isn't a values type, then make it into one.
+(defun-cached (%coerce-to-values
+ :hash-bits 8
+ :hash-function (lambda (type)
+ (logand (type-hash-value type)
+ #xff)))
+ ((type eq))
+ (cond ((multiple-value-bind (res sure)
+ (csubtypep (specifier-type 'null) type)
+ (and (not res) sure))
+ ;; FIXME: What should we do with (NOT SURE)?
+ (make-values-type :required (list type) :rest *universal-type*))
+ (t
+ (make-values-type :optional (list type) :rest *universal-type*))))
+
(defun coerce-to-values (type)
(declare (type ctype type))
- (if (values-type-p type)
- type
- (make-values-type :required (list type) :rest *universal-type*)))
+ (cond ((or (eq type *universal-type*)
+ (eq type *wild-type*))
+ *wild-type*)
+ ((values-type-p type)
+ type)
+ (t (%coerce-to-values type))))
+
+;;; Return type, corresponding to ANSI short form of VALUES type
+;;; specifier.
+(defun make-short-values-type (types)
+ (declare (list types))
+ (let ((last-required (position-if
+ (lambda (type)
+ (not/type (csubtypep (specifier-type 'null) type)))
+ types
+ :from-end t)))
+ (if last-required
+ (make-values-type :required (subseq types 0 (1+ last-required))
+ :optional (subseq types (1+ last-required))
+ :rest *universal-type*)
+ (make-values-type :optional types :rest *universal-type*))))
+
+(defun make-single-value-type (type)
+ (make-values-type :required (list type)))
;;; Do the specified OPERATION on TYPE1 and TYPE2, which may be any
;;; type, including VALUES types. With VALUES types such as:
;;; OPERATION returned true as its second value each time we called
;;; it. Since we approximate the intersection of VALUES types, the
;;; second value being true doesn't mean the result is exact.
-(defun args-type-op (type1 type2 operation nreq default-type)
- (declare (type ctype type1 type2 default-type)
+(defun args-type-op (type1 type2 operation nreq)
+ (declare (type ctype type1 type2)
(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)))
- (multiple-value-bind (types1 rest1)
- (values-type-types type1 default-type)
- (multiple-value-bind (types2 rest2)
- (values-type-types type2 default-type)
- (multiple-value-bind (rest rest-exact)
- (funcall operation rest1 rest2)
- (multiple-value-bind (res res-exact)
- (if (< (length types1) (length types2))
- (fixed-values-op types2 types1 rest1 operation)
- (fixed-values-op types1 types2 rest2 operation))
- (let* ((req (funcall nreq
- (length (args-type-required type1))
- (length (args-type-required type2))))
- (required (subseq res 0 req))
- (opt (subseq res req))
- (opt-last (position rest opt :test-not #'type=
- :from-end t)))
- (if (find *empty-type* required :test #'type=)
- (values *empty-type* t)
- (values (make-values-type
- :required required
- :optional (if opt-last
- (subseq opt 0 (1+ opt-last))
- ())
- :rest (if (eq rest default-type) nil rest))
- (and rest-exact res-exact)))))))))
- (funcall operation type1 type2)))
+ (multiple-value-bind (types1 rest1)
+ (values-type-types type1)
+ (multiple-value-bind (types2 rest2)
+ (values-type-types type2)
+ (multiple-value-bind (rest rest-exact)
+ (funcall operation rest1 rest2)
+ (multiple-value-bind (res res-exact)
+ (if (< (length types1) (length types2))
+ (fixed-values-op types2 types1 rest1 operation)
+ (fixed-values-op types1 types2 rest2 operation))
+ (let* ((req (funcall nreq
+ (length (args-type-required type1))
+ (length (args-type-required type2))))
+ (required (subseq res 0 req))
+ (opt (subseq res req)))
+ (values (make-values-type
+ :required required
+ :optional opt
+ :rest rest)
+ (and rest-exact res-exact))))))))
;;; Do a union or intersection operation on types that might be values
;;; types. The result is optimized for utility rather than exactness,
:hash-bits 8
:default nil
:init-wrapper !cold-init-forms)
- ((type1 eq) (type2 eq))
+ ((type1 eq) (type2 eq))
(declare (type ctype type1 type2))
(cond ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) *wild-type*)
- ((eq type1 *empty-type*) type2)
- ((eq type2 *empty-type*) type1)
- (t
- (values (args-type-op type1 type2 #'type-union #'min *empty-type*)))))
+ ((eq type1 *empty-type*) type2)
+ ((eq type2 *empty-type*) type1)
+ (t
+ (values (args-type-op type1 type2 #'type-union #'min)))))
+
(defun-cached (values-type-intersection :hash-function type-cache-hash
:hash-bits 8
:values 2
:default (values nil :empty)
:init-wrapper !cold-init-forms)
- ((type1 eq) (type2 eq))
+ ((type1 eq) (type2 eq))
(declare (type ctype type1 type2))
- (cond ((eq type1 *wild-type*) (values type2 t))
- ((eq type2 *wild-type*) (values type1 t))
- (t
- (args-type-op type1 type2
- #'type-intersection
- #'max
- (specifier-type 'null)))))
+ (cond ((eq type1 *wild-type*) (values (coerce-to-values type2) t))
+ ((or (eq type2 *wild-type*) (eq type2 *universal-type*))
+ (values type1 t))
+ ((or (eq type1 *empty-type*) (eq type2 *empty-type*))
+ *empty-type*)
+ ((and (not (values-type-p type2))
+ (values-type-required type1))
+ (let ((req1 (values-type-required type1)))
+ (make-values-type :required (cons (type-intersection (first req1) type2)
+ (rest req1))
+ :optional (values-type-optional type1)
+ :rest (values-type-rest type1)
+ :allowp (values-type-allowp type1))))
+ (t
+ (args-type-op type1 (coerce-to-values type2)
+ #'type-intersection
+ #'max))))
;;; This is like TYPES-EQUAL-OR-INTERSECT, except that it sort of
;;; works on VALUES types. Note that due to the semantics of
(defun values-types-equal-or-intersect (type1 type2)
(cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*))
(values t t))
- ((or (values-type-p type1) (values-type-p type2))
+ ((or (eq type1 *wild-type*) (eq type2 *wild-type*))
+ (values t t))
+ (t
(multiple-value-bind (res win) (values-type-intersection type1 type2)
(values (not (eq res *empty-type*))
- win)))
- (t
- (types-equal-or-intersect type1 type2))))
+ win)))))
;;; a SUBTYPEP-like operation that can be used on any types, including
;;; VALUES types
:values 2
:default (values nil :empty)
:init-wrapper !cold-init-forms)
- ((type1 eq) (type2 eq))
+ ((type1 eq) (type2 eq))
(declare (type ctype type1 type2))
- (cond ((eq type2 *wild-type*) (values t t))
- ((eq type1 *wild-type*)
- (values (eq type2 *universal-type*) t))
- ((not (values-types-equal-or-intersect type1 type2))
- (values nil t))
- (t
- (if (or (values-type-p type1) (values-type-p type2))
- (let ((type1 (coerce-to-values type1))
- (type2 (coerce-to-values type2)))
- (multiple-value-bind (types1 rest1) (values-type-types type1)
- (multiple-value-bind (types2 rest2) (values-type-types type2)
- (cond ((< (length (values-type-required type1))
- (length (values-type-required type2)))
- (values nil t))
- ((< (length types1) (length types2))
- (values nil nil))
- ((or (values-type-keyp type1)
- (values-type-keyp type2))
- (values nil nil))
- (t
- (do ((t1 types1 (rest t1))
- (t2 types2 (rest t2)))
- ((null t2)
- (csubtypep rest1 rest2))
- (multiple-value-bind (res win-p)
- (csubtypep (first t1) (first t2))
- (unless win-p
- (return (values nil nil)))
- (unless res
- (return (values nil t))))))))))
- (csubtypep type1 type2)))))
+ (cond ((or (eq type2 *wild-type*) (eq type2 *universal-type*)
+ (eq type1 *empty-type*))
+ (values t t))
+ ((eq type1 *wild-type*)
+ (values (eq type2 *wild-type*) t))
+ ((or (eq type2 *empty-type*)
+ (not (values-types-equal-or-intersect type1 type2)))
+ (values nil t))
+ ((and (not (values-type-p type2))
+ (values-type-required type1))
+ (csubtypep (first (values-type-required type1))
+ type2))
+ (t (setq type2 (coerce-to-values type2))
+ (multiple-value-bind (types1 rest1) (values-type-types type1)
+ (multiple-value-bind (types2 rest2) (values-type-types type2)
+ (cond ((< (length (values-type-required type1))
+ (length (values-type-required type2)))
+ (values nil t))
+ ((< (length types1) (length types2))
+ (values nil nil))
+ (t
+ (do ((t1 types1 (rest t1))
+ (t2 types2 (rest t2)))
+ ((null t2)
+ (csubtypep rest1 rest2))
+ (multiple-value-bind (res win-p)
+ (csubtypep (first t1) (first t2))
+ (unless win-p
+ (return (values nil nil)))
+ (unless res
+ (return (values nil t))))))))))))
\f
;;;; type method interfaces
(declare (type ctype type1 type2))
(cond ((or (eq type1 type2)
(eq type1 *empty-type*)
- (eq type2 *wild-type*))
+ (eq type2 *universal-type*))
(values t t))
- ((eq type1 *wild-type*)
+ #+nil
+ ((eq type1 *universal-type*)
(values nil t))
(t
(!invoke-type-method :simple-subtypep :complex-subtypep-arg2
;;;; These are fully general operations on CTYPEs: they'll always
;;;; return a CTYPE representing the result.
-;;; shared logic for unions and intersections: Stuff TYPE into the
-;;; vector TYPES, finding pairs of types which can be simplified by
-;;; SIMPLIFY2 (TYPE-UNION2 or TYPE-INTERSECTION2) and replacing them
-;;; by their simplified forms.
-(defun accumulate1-compound-type (type types %compound-type-p simplify2)
- (declare (type ctype type))
- (declare (type (vector ctype) types))
- (declare (type function %compound-type-p simplify2))
- ;; Any input object satisfying %COMPOUND-TYPE-P should've been
- ;; broken into components before it reached us.
- (aver (not (funcall %compound-type-p type)))
- (dotimes (i (length types) (vector-push-extend type types))
- (let ((simplified2 (funcall simplify2 type (aref types i))))
- (when simplified2
- ;; Discard the old (AREF TYPES I).
- (setf (aref types i) (vector-pop types))
- ;; Merge the new SIMPLIFIED2 into TYPES, by tail recursing.
- ;; (Note that the tail recursion is indirect: we go through
- ;; ACCUMULATE, not ACCUMULATE1, so that if SIMPLIFIED2 is
- ;; handled properly if it satisfies %COMPOUND-TYPE-P.)
- (return (accumulate-compound-type simplified2
- types
- %compound-type-p
- simplify2)))))
- ;; Voila.
- (values))
-
-;;; shared logic for unions and intersections: Use
-;;; ACCUMULATE1-COMPOUND-TYPE to merge TYPE into TYPES, either
-;;; all in one step or, if %COMPOUND-TYPE-P is satisfied,
-;;; component by component.
-(defun accumulate-compound-type (type types %compound-type-p simplify2)
- (declare (type function %compound-type-p simplify2))
- (flet ((accumulate1 (x)
- (accumulate1-compound-type x types %compound-type-p simplify2)))
- (declare (inline accumulate1))
- (if (funcall %compound-type-p type)
- (map nil #'accumulate1 (compound-type-types type))
- (accumulate1 type)))
- (values))
-
;;; shared logic for unions and intersections: Return a vector of
-;;; types representing the same types as INPUT-TYPES, but with
+;;; types representing the same types as INPUT-TYPES, but with
;;; COMPOUND-TYPEs satisfying %COMPOUND-TYPE-P broken up into their
;;; component types, and with any SIMPLY2 simplifications applied.
+(declaim (inline simplified-compound-types))
(defun simplified-compound-types (input-types %compound-type-p simplify2)
- (let ((simplified-types (make-array (length input-types)
- :fill-pointer 0
- :adjustable t
- :element-type 'ctype
- ;; (This INITIAL-ELEMENT shouldn't
- ;; matter, but helps avoid type
- ;; warnings at compile time.)
- :initial-element *empty-type*)))
- (dolist (input-type input-types)
- (accumulate-compound-type input-type
- simplified-types
- %compound-type-p
- simplify2))
- simplified-types))
+ (declare (function %compound-type-p simplify2))
+ (let ((types (make-array (length input-types)
+ :fill-pointer 0
+ :adjustable t
+ :element-type 'ctype)))
+ (labels ((accumulate-compound-type (type)
+ (if (funcall %compound-type-p type)
+ (dolist (type (compound-type-types type))
+ (accumulate1-compound-type type))
+ (accumulate1-compound-type type)))
+ (accumulate1-compound-type (type)
+ (declare (type ctype type))
+ ;; Any input object satisfying %COMPOUND-TYPE-P should've been
+ ;; broken into components before it reached us.
+ (aver (not (funcall %compound-type-p type)))
+ (dotimes (i (length types) (vector-push-extend type types))
+ (let ((simplified2 (funcall simplify2 type (aref types i))))
+ (when simplified2
+ ;; Discard the old (AREF TYPES I).
+ (setf (aref types i) (vector-pop types))
+ ;; Merge the new SIMPLIFIED2 into TYPES, by tail recursing.
+ ;; (Note that the tail recursion is indirect: we go through
+ ;; ACCUMULATE, not ACCUMULATE1, so that if SIMPLIFIED2 is
+ ;; handled properly if it satisfies %COMPOUND-TYPE-P.)
+ (return (accumulate-compound-type simplified2)))))))
+ (dolist (input-type input-types)
+ (accumulate-compound-type input-type)))
+ types))
;;; shared logic for unions and intersections: Make a COMPOUND-TYPE
;;; object whose components are the types in TYPES, or skip to special
;; KLUDGE: In ANSI, * isn't really the name of a type, it's just a
;; special symbol which can be stuck in some places where an
;; ordinary type can go, e.g. (ARRAY * 1) instead of (ARRAY T 1).
- ;; At some point, in order to become more standard, we should
- ;; convert all the classic CMU CL legacy *s and *WILD-TYPE*s into
- ;; Ts and *UNIVERSAL-TYPE*s.
+ ;; In SBCL it also used to denote universal VALUES type.
(frob * *wild-type*)
(frob nil *empty-type*)
(frob t *universal-type*))
:returns *wild-type*)))
(!define-type-method (named :simple-=) (type1 type2)
- ;; FIXME: BUG 85: This assertion failed when I added it in
- ;; sbcl-0.6.11.13. It probably shouldn't fail; but for now it's
- ;; just commented out.
;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type.
(values (eq type1 type2) t))
(values nil nil))
(t
;; By elimination, TYPE1 is the universal type.
- (aver (or (eq type1 *wild-type*) (eq type1 *universal-type*)))
+ (aver (eq type1 *universal-type*))
;; This case would have been picked off by the SIMPLE-SUBTYPEP
;; method, and so shouldn't appear here.
(aver (not (eq type2 *universal-type*)))
(!define-type-method (hairy :unparse) (x)
(hairy-type-specifier x))
-
+
(!define-type-method (hairy :simple-subtypep) (type1 type2)
(let ((hairy-spec1 (hairy-type-specifier type1))
(hairy-spec2 (hairy-type-specifier type2)))
(let ((complement-type1 (negation-type-type type1)))
;; Do the special cases first, in order to give us a chance if
;; subtype/supertype relationships are hairy.
- (multiple-value-bind (equal certain)
+ (multiple-value-bind (equal certain)
(type= complement-type1 type2)
;; If a = b, ~a is not a subtype of b (unless b=T, which was
;; excluded above).
(numeric-type-high type2)
>= > t)))
(t nil))))))
-
+
(!cold-init-forms
(setf (info :type :kind 'number)
(return nil)))
(setf accumulator
(type-intersection accumulator union))))))))
-
+
(!def-type-translator and (&whole whole &rest type-specifiers)
(apply #'type-intersection
(mapcar #'specifier-type
;; (OR STRING BIT-VECTOR)]
(progn
(aver (= (length (array-type-dimensions type)) 1))
- (let ((etype (type-specifier
- (array-type-specialized-element-type type)))
+ (let* ((etype (type-specifier
+ (array-type-specialized-element-type type)))
+ (etype (if (eq etype '*) t etype))
(type-length (car (array-type-dimensions type))))
(unless (or (eq type-length '*)
(= type-length length))
;;; like FILE-POSITION, only using :FILE-LENGTH
(defun file-length (stream)
- (declare (type (or file-stream synonym-stream) stream))
+ ;; FIXME: The following declaration uses yet undefined types, which
+ ;; cause cross-compiler hangup.
+ ;;
+ ;; (declare (type (or file-stream synonym-stream) stream))
(stream-must-be-associated-with-file stream)
(funcall (ansi-stream-misc stream) stream :file-length))
\f
;;;; interface to enabling and disabling signal handlers
(defun enable-interrupt (signal-designator handler)
- (declare (type (or function (member :default :ignore)) handler))
+ (declare (type (or function fixnum (member :default :ignore)) handler))
(without-gcing
(let ((result (install-handler (unix-signal-number signal-designator)
(case handler
handler))))))
(cond ((= result sig_dfl) :default)
((= result sig_ign) :ignore)
- (t (the function (sb!kernel:make-lisp-obj result)))))))
+ (t (the (or function fixnum) (sb!kernel:make-lisp-obj result)))))))
(defun default-interrupt (signal)
(enable-interrupt signal :default))
;;; Clear memoization of all type system operations that can be
;;; altered by type definition/redefinition.
+;;;
+;;; FIXME: This should be autogenerated.
(defun clear-type-caches ()
(declare (special *type-system-initialized*))
(when *type-system-initialized*
(enumerable nil :read-only t)
;; an arbitrary hash code used in EQ-style hashing of identity
;; (since EQ hashing can't be done portably)
- (hash-value (random (1+ most-positive-fixnum))
+ (hash-value (random #.(ash 1 20))
:type (and fixnum unsigned-byte)
:read-only t)
;; Can this object contain other types? A global property of our
(logand (logxor (ash (type-hash-value type1) -3)
(type-hash-value type2))
#xFF))
+#!-sb-fluid (declaim (inline type-list-cache-hash))
+(declaim (ftype (function (list) (unsigned-byte 8)) type-list-cache-hash))
+(defun type-list-cache-hash (types)
+ (logand (loop with res = 0
+ for type in types
+ for hash = (type-hash-value type)
+ do (setq res (logxor res hash))
+ finally (return res))
+ #xFF))
\f
;;;; cold loading initializations
(defvar *num-fixups* 0)
;;; FIXME: When the system runs, it'd be interesting to see what this is.
+(declaim (inline adjust-fixup-array))
+(defun adjust-fixup-array (array size)
+ (let ((length (length array))
+ (new (make-array size :element-type '(unsigned-byte 32))))
+ (replace new array)
+ new))
+
;;; This gets called by LOAD to resolve newly positioned objects
;;; with things (like code instructions) that have to refer to them.
;;;
(let ((fixups (code-header-ref code code-constants-offset)))
(cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
(let ((new-fixups
- (adjust-array fixups (1+ (length fixups))
- :element-type '(unsigned-byte 32))))
+ (adjust-fixup-array fixups (1+ (length fixups)))))
(setf (aref new-fixups (length fixups)) offset)
(setf (code-header-ref code code-constants-offset)
new-fixups)))
(zerop fixups))
(format t "** Init. code FU = ~S~%" fixups)) ; FIXME
(setf (code-header-ref code code-constants-offset)
- (make-specializable-array
+ (make-array
1
:element-type '(unsigned-byte 32)
:initial-element offset)))))))
(let ((fixups (code-header-ref code code-constants-offset)))
(cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
(let ((new-fixups
- (adjust-array fixups (1+ (length fixups))
- :element-type '(unsigned-byte 32))))
+ (adjust-fixup-array fixups (1+ (length fixups)))))
(setf (aref new-fixups (length fixups)) offset)
(setf (code-header-ref code code-constants-offset)
new-fixups)))
(zerop fixups))
(sb!impl::!cold-lose "Argh! can't process fixup"))
(setf (code-header-ref code code-constants-offset)
- (make-specializable-array
+ (make-array
1
:element-type '(unsigned-byte 32)
:initial-element offset)))))))
((function type &rest args) node ltn-policy)
(setf (basic-combination-info node) :funny)
(setf (node-tail-p node) nil)
- (annotate-ordinary-continuation function ltn-policy)
+ (annotate-ordinary-continuation function)
(dolist (arg args)
- (annotate-ordinary-continuation arg ltn-policy)))
+ (annotate-ordinary-continuation arg)))
(defoptimizer (%alien-funcall ir2-convert)
((function type &rest args) call block)
(defun weaken-values-type (type)
(declare (type ctype type))
(cond ((eq type *wild-type*) type)
- ((values-type-p type)
+ ((not (values-type-p type))
+ (weaken-type type))
+ (t
(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))))
+ (weaken-type it)))))))
\f
;;;; checking strategy determination
(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))
+ (no-fun-values-types (continuation-derived-type cont))
(if (eq count :unknown)
(if (and (every #'type-check-template types) (not force-hairy))
(values :simple types)
;;; 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 force-hairy)
- (declare (type continuation cont))
- (let ((ctype (continuation-type-to-check cont))
- (atype (continuation-asserted-type cont))
- (dest (continuation-dest cont)))
+(defun cast-check-types (cast force-hairy)
+ (declare (type cast cast))
+ (let* ((cont (node-cont cast))
+ (ctype (coerce-to-values (cast-type-to-check cast)))
+ (atype (coerce-to-values (cast-asserted-type cast)))
+ (value (cast-value cast))
+ (vtype (continuation-derived-type value))
+ (dest (continuation-dest cont)))
(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 atype)
- (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)))))))
+ (multiple-value-bind (vtypes vcount) (values-types vtype)
+ (declare (ignore vtypes))
+ (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 value ctypes atypes t)
+ (maybe-negate-check value ctypes atypes force-hairy)))
+ ((and (continuation-single-value-p cont)
+ (or (not (args-type-rest ctype))
+ (eq (args-type-rest ctype) *universal-type*)))
+ (let ((creq (car (args-type-required ctype))))
+ (multiple-value-setq (ctype atype)
+ (if creq
+ (values creq (car (args-type-required atype)))
+ (values (car (args-type-optional ctype))
+ (car (args-type-optional atype)))))
+ (maybe-negate-check value
+ (list ctype) (list atype)
+ force-hairy)))
+ ((and (mv-combination-p dest)
+ (eq (mv-combination-kind dest) :local))
+ (let* ((fun-ref (continuation-use (mv-combination-fun dest)))
+ (length (length (lambda-vars (ref-leaf fun-ref)))))
+ (maybe-negate-check value
+ ;; FIXME
+ (adjust-list (values-type-types ctype)
+ length
+ *universal-type*)
+ (adjust-list (values-type-types atype)
+ length
+ *universal-type*)
+ force-hairy)))
+ ((not (eq vcount :unknown))
+ (maybe-negate-check value
+ (values-type-start ctype vcount)
+ (values-type-start atype vcount)
+ t))
+ (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))
+(defun worth-type-check-p (cast)
+ (declare (type cast cast))
+ (let* ((cont (node-cont cast))
+ (dest (continuation-dest cont)))
+ (not (or (not (cast-type-check cast))
(and (combination-p dest)
(let ((kind (combination-kind dest)))
(or (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.)
(and (fun-info-p kind)
(null (fun-info-templates kind))
(not (fun-info-ir2-convert kind)))))
- ;; 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))))))
+ (and
+ (immediately-used-p cont cast)
+ (values-subtypep (continuation-externally-checkable-type cont)
+ (cast-type-to-check cast))))))))
;;; 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
;;; -- the continuation is an argument to a known function that has
;;; no IR2-CONVERT method or :FAST-SAFE templates that are
;;; compatible with the call's type.
-;;;
-;;; We must only return NIL when it is *certain* that a check will not
-;;; be done, since if we pass up this chance to do the check, it will
-;;; be too late. The penalty for being too conservative is duplicated
-;;; type checks. The penalty for erring by being too speculative is
-;;; much nastier, e.g. falling through without ever being able to find
-;;; an appropriate VOP.
-(defun probable-type-check-p (cont)
- (declare (type continuation cont))
- (let ((dest (continuation-dest cont)))
+(defun probable-type-check-p (cast)
+ (declare (type cast cast))
+ (let* ((cont (node-cont cast))
+ (dest (continuation-dest cont)))
+ (cond ((not dest) nil)
+ (t t))
+ #+nil
(cond ((or (not dest)
(policy dest (zerop safety)))
nil)
(when (or val (not win)) (return t)))))))))
(t t))))
-;;; Return a form that we can convert to do a hairy type check of the
-;;; specified TYPES. TYPES is a list of the format returned by
-;;; CONTINUATION-CHECK-TYPES in the :HAIRY case. In place of the
-;;; actual value(s) we are to check, we use 'DUMMY. This constant
-;;; reference is later replaced with the actual values continuation.
+;;; Return a lambda form that we can convert to do a hairy type check
+;;; of the specified TYPES. TYPES is a list of the format returned by
+;;; CONTINUATION-CHECK-TYPES in the :HAIRY case.
;;;
;;; Note that we don't attempt to check for required values being
;;; unsupplied. Such checking is impossible to efficiently do at the
;;; source level because our fixed-values conventions are optimized
;;; for the common MV-BIND case.
-;;;
-;;; We can always use MULTIPLE-VALUE-BIND, since the macro is clever
-;;; about binding a single variable.
(defun make-type-check-form (types)
(let ((temps (make-gensym-list (length types))))
- `(multiple-value-bind ,temps 'dummy
+ `(multiple-value-bind ,temps
+ 'dummy
,@(mapcar (lambda (temp type)
- (let* ((spec
- (let ((*unparse-fun-type-simplify* t))
- (type-specifier (second type))))
- (test (if (first type) `(not ,spec) spec)))
- `(unless (typep ,temp ',test)
- (%type-check-error
- ,temp
- ',(type-specifier (third type))))))
- temps
- types)
+ (let* ((spec
+ (let ((*unparse-fun-type-simplify* t))
+ (type-specifier (second type))))
+ (test (if (first type) `(not ,spec) spec)))
+ `(unless (typep ,temp ',test)
+ (%type-check-error
+ ,temp
+ ',(type-specifier (third type))))))
+ temps
+ types)
(values ,@temps))))
;;; Splice in explicit type check code immediately before the node
;;; which is CONT's DEST. This code receives the value(s) that were
;;; being passed to CONT, checks the type(s) of the value(s), then
;;; passes them on to CONT.
-(defun convert-type-check (cont types)
- (declare (type continuation cont) (type list types))
- (with-ir1-environment-from-node (continuation-dest cont)
-
- ;; Ensuring that CONT starts a block lets us freely manipulate its uses.
- (ensure-block-start cont)
-
- ;; Make a new continuation and move CONT's uses to it.
- (let* ((new-start (make-continuation))
- (dest (continuation-dest cont))
- (prev (node-prev dest)))
- (continuation-starts-block new-start)
- (substitute-continuation-uses new-start cont)
-
- ;; Setting TYPE-CHECK in CONT to :DELETED indicates that the
- ;; check has been done.
- (setf (continuation-%type-check cont) :deleted)
-
- ;; Make the DEST node start its block so that we can splice in
- ;; the type check code.
- (when (continuation-use prev)
- (node-ends-block (continuation-use prev)))
-
- (let* ((prev-block (continuation-block prev))
- (new-block (continuation-block new-start))
- (dummy (make-continuation)))
-
- ;; Splice in the new block before DEST, giving the new block
- ;; all of DEST's predecessors.
- (dolist (block (block-pred prev-block))
- (change-block-successor block prev-block new-block))
-
- ;; Convert the check form, using the new block start as START
- ;; and a dummy continuation as CONT.
- (ir1-convert new-start dummy (make-type-check-form types))
-
- ;; TO DO: Why should this be true? -- WHN 19990601
- (aver (eq (continuation-block dummy) new-block))
-
- ;; KLUDGE: Comments at the head of this function in CMU CL
- ;; said that somewhere in here we
- ;; Set the new block's start and end cleanups to the *start*
- ;; cleanup of PREV's block. This overrides the incorrect
- ;; default from WITH-IR1-ENVIRONMENT-FROM-NODE.
- ;; Unfortunately I can't find any code which corresponds to this.
- ;; Perhaps it was a stale comment? Or perhaps I just don't
- ;; understand.. -- WHN 19990521
-
- (let ((node (continuation-use dummy)))
- (setf (block-last new-block) node)
- ;; Change the use to a use of CONT. (We need to use the
- ;; dummy continuation to get the control transfer right,
- ;; because we want to go to PREV's block, not CONT's.)
- (delete-continuation-use node)
- (add-continuation-use node cont))
- ;; Link the new block to PREV's block.
- (link-blocks new-block prev-block))
-
- ;; MAKE-TYPE-CHECK-FORM generated a form which checked the type
- ;; of 'DUMMY, not a real form. At this point we convert to the
- ;; real form by finding 'DUMMY and overwriting it with the new
- ;; continuation. (We can find 'DUMMY because no LET conversion
- ;; has been done yet.) The [mv-]combination code from the
- ;; mv-bind in the check form will be the use of the new check
- ;; continuation. We substitute for the first argument of this
- ;; node.
- (let* ((node (continuation-use cont))
- (args (basic-combination-args node))
- (victim (first args)))
- (aver (and (= (length args) 1)
- (eq (constant-value
- (ref-leaf
- (continuation-use victim)))
- 'dummy)))
- (substitute-continuation new-start victim)))
-
- ;; Invoking local call analysis converts this call to a LET.
- (locall-analyze-component *current-component*))
+(defun convert-type-check (cast types)
+ (declare (type cast cast) (type list types))
+ (let ((cont (cast-value cast))
+ (length (length types)))
+ (filter-continuation cont (make-type-check-form types))
+ (reoptimize-continuation (cast-value cast))
+ (setf (cast-type-to-check cast) *wild-type*)
+ (setf (cast-%type-check cast) nil)
+ (let* ((atype (cast-asserted-type cast))
+ (atype (cond ((not (values-type-p atype))
+ atype)
+ ((= length 1)
+ (single-value-type atype))
+ (t
+ (make-values-type :required
+ (values-type-start atype length)))))
+ (dtype (node-derived-type cast))
+ (dtype (make-values-type :required
+ (values-type-start dtype length))))
+ (setf (cast-asserted-type cast) atype)
+ (setf (node-derived-type cast) dtype)))
(values))
-;;; Emit a type warning for NODE. If the value of NODE is being used
-;;; for a variable binding, we figure out which one for source
-;;; context. If the value is a constant, we print it specially. We
-;;; ignore nodes whose type is NIL, since they are supposed to never
-;;; return.
-(defun emit-type-warning (node)
- (declare (type node node))
- (let* ((*compiler-error-context* node)
- (cont (node-cont node))
- (atype-spec (type-specifier (continuation-asserted-type cont)))
- (dtype (node-derived-type node))
- (dest (continuation-dest cont))
- (what (when (and (combination-p dest)
- (eq (combination-kind dest) :local))
- (let ((lambda (combination-lambda dest))
- (pos (position-or-lose cont (combination-args dest))))
- (format nil "~:[A possible~;The~] binding of ~S"
- (and (continuation-use cont)
- (eq (functional-kind lambda) :let))
- (leaf-source-name (elt (lambda-vars lambda)
- pos)))))))
- (cond ((eq dtype *empty-type*))
- ((and (ref-p node) (constant-p (ref-leaf node)))
- (compiler-warn "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S"
- what atype-spec (constant-value (ref-leaf node))))
- (t
- (compiler-warn
- "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
- what (type-specifier dtype) atype-spec))))
+;;; Check all possible arguments of CAST and emit type warnings for
+;;; those with type errors. If the value of USE is being used for a
+;;; variable binding, we figure out which one for source context. If
+;;; the value is a constant, we print it specially.
+(defun cast-check-uses (cast)
+ (declare (type cast cast))
+ (let* ((cont (node-cont cast))
+ (dest (continuation-dest cont))
+ (value (cast-value cast))
+ (atype (cast-asserted-type cast)))
+ (do-uses (use value)
+ (let ((dtype (node-derived-type use)))
+ (unless (values-types-equal-or-intersect dtype atype)
+ (let* ((*compiler-error-context* use)
+ (atype-spec (type-specifier atype))
+ (what (when (and (combination-p dest)
+ (eq (combination-kind dest) :local))
+ (let ((lambda (combination-lambda dest))
+ (pos (position-or-lose
+ cont (combination-args dest))))
+ (format nil "~:[A possible~;The~] binding of ~S"
+ (and (continuation-use cont)
+ (eq (functional-kind lambda) :let))
+ (leaf-source-name (elt (lambda-vars lambda)
+ pos)))))))
+ (cond ((and (ref-p use) (constant-p (ref-leaf use)))
+ (compiler-warn "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S"
+ what atype-spec (constant-value (ref-leaf use))))
+ (t
+ (compiler-warn
+ "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
+ what (type-specifier dtype) atype-spec))))))))
(values))
;;; Loop over all blocks in COMPONENT that have TYPE-CHECK set,
;;; which may lead to inappropriate template choices due to the
;;; modification of argument types.
(defun generate-type-checks (component)
- (collect ((conts))
+ (collect ((casts))
(do-blocks (block component)
(when (block-type-check block)
(do-nodes (node cont block)
- (let ((type-check (continuation-type-check cont)))
- (unless (member type-check '(nil :deleted))
- (let ((atype (continuation-asserted-type cont)))
- (do-uses (use cont)
- (unless (values-types-equal-or-intersect
- (node-derived-type use) atype)
- (unless (policy node (= inhibit-warnings 3))
- (emit-type-warning use))))))
- (when (eq type-check t)
- (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))))))
+ (when (cast-p node)
+ (when (cast-type-check node)
+ (cast-check-uses node))
+ (cond ((worth-type-check-p node)
+ (casts (cons node (not (probable-type-check-p node)))))
+ (t
+ (setf (cast-%type-check node) nil)
+ (setf (cast-type-to-check node) *wild-type*)))))
(setf (block-type-check block) nil)))
- (dolist (cont (conts))
- (destructuring-bind (cont . force-hairy) cont
+ (dolist (cast (casts))
+ (destructuring-bind (cast . force-hairy) cast
(multiple-value-bind (check types)
- (continuation-check-types cont force-hairy)
+ (cast-check-types cast force-hairy)
(ecase check
(:simple)
(:hairy
- (convert-type-check cont types))
+ (convert-type-check cast types))
(:too-hairy
- (let* ((context (continuation-dest cont))
- (*compiler-error-context* context))
- (when (policy context (>= safety inhibit-warnings))
+ (let ((*compiler-error-context* cast))
+ (when (policy cast (>= safety inhibit-warnings))
(compiler-note
"type assertion too complex to check:~% ~S."
- (type-specifier (continuation-asserted-type cont)))))
- (setf (continuation-%type-check cont) :deleted)))))))
+ (type-specifier (cast-asserted-type cast)))))
+ (setf (cast-type-to-check cast) *wild-type*)
+ (setf (cast-%type-check cast) nil)))))))
(values))
(defun constrain-float-type (x y greater or-equal)
(declare (type numeric-type x y))
(declare (ignorable x y greater or-equal)) ; for CROSS-FLOAT-INFINITY-KLUDGE
-
+
(aver (eql (numeric-type-class x) 'float))
(aver (eql (numeric-type-class y) 'float))
#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(let* ((cont (node-cont ref))
(dest (continuation-dest cont)))
(cond ((and (if-p dest)
- (csubtypep (specifier-type 'null) not-res)
- (eq (continuation-asserted-type cont) *wild-type*))
+ (csubtypep (specifier-type 'null) not-res))
(setf (node-derived-type ref) *wild-type*)
(change-ref-leaf ref (find-constant t)))
(t
- (derive-node-type ref (or (type-difference res not-res)
- res)))))))
+ (derive-node-type ref
+ (make-single-value-type
+ (or (type-difference res not-res)
+ res))))))))
(values))
(when var
(when ref-preprocessor
(funcall ref-preprocessor node gen))
- (when (continuation-type-check cont)
- (let* ((atype (continuation-derived-type cont))
- (con (find-constraint 'typep var atype nil)))
- (sset-adjoin con gen))))))
+ (let ((dest (continuation-dest cont)))
+ (when (cast-p dest)
+ (let* ((atype (single-value-type (cast-derived-type dest))) ; FIXME
+ (con (find-constraint 'typep var atype nil)))
+ (sset-adjoin con gen)))))))
(cset
(let ((var (set-var node)))
(when (lambda-var-p var)
(let ((cons (lambda-var-constraints var)))
(when cons
(sset-difference gen cons)
- (let* ((type (node-derived-type node))
+ (let* ((type (single-value-type (node-derived-type node)))
(con (find-constraint 'typep var type nil)))
(sset-adjoin con gen)))))))))
;;; combination node so that COMPILER-WARNING and related functions
;;; will do the right thing if they are supplied.
(defun valid-fun-use (call type &key
- ((:argument-test *ctype-test-fun*) #'csubtypep)
- (result-test #'values-subtypep)
- (strict-result nil)
- ((:lossage-fun *lossage-fun*))
- ((:unwinnage-fun *unwinnage-fun*)))
+ ((:argument-test *ctype-test-fun*) #'csubtypep)
+ (result-test #'values-subtypep)
+ ((:lossage-fun *lossage-fun*))
+ ((:unwinnage-fun *unwinnage-fun*)))
(declare (type function result-test) (type combination call)
;; FIXME: Could TYPE here actually be something like
;; (AND GENERIC-FUNCTION (FUNCTION (T) T))? How
(let* ((*lossage-detected* nil)
(*unwinnage-detected* nil)
(*compiler-error-context* call)
- (args (combination-args call))
- (nargs (length args)))
+ (args (combination-args call)))
(if (fun-type-p type)
- (let* ((required (fun-type-required type))
- (min-args (length required))
- (optional (fun-type-optional type))
- (max-args (+ min-args (length optional)))
- (rest (fun-type-rest type))
- (keyp (fun-type-keyp type)))
- (cond
- ((fun-type-wild-args type)
- (do ((i 1 (1+ i))
- (arg args (cdr arg)))
- ((null arg))
- (check-arg-type (car arg) *wild-type* i)))
- ((not (or optional keyp rest))
- (if (/= nargs min-args)
- (note-lossage
- "The function was called with ~R argument~:P, but wants exactly ~R."
- nargs min-args)
- (check-fixed-and-rest args required nil)))
- ((< nargs min-args)
- (note-lossage
- "The function was called with ~R argument~:P, but wants at least ~R."
- nargs min-args))
- ((<= nargs max-args)
- (check-fixed-and-rest args (append required optional) rest))
- ((not (or keyp rest))
- (note-lossage
- "The function was called with ~R argument~:P, but wants at most ~R."
- nargs max-args))
- ((and keyp (oddp (- nargs max-args)))
- (note-lossage
- "The function has an odd number of arguments in the keyword portion."))
- (t
- (check-fixed-and-rest args (append required optional) rest)
- (when keyp
- (check-key-args args max-args type))))
-
- (let* ((dtype (node-derived-type call))
- (return-type (fun-type-returns type))
- (cont (node-cont call))
- (out-type
- (if (or (not (continuation-type-check cont))
- (and strict-result (policy call (/= safety 0))))
- dtype
- (values-type-intersection (continuation-asserted-type cont)
- dtype))))
- (multiple-value-bind (int win) (funcall result-test out-type return-type)
- (cond ((not win)
- (note-unwinnage "can't tell whether the result is a ~S"
- (type-specifier return-type)))
- ((not int)
- (note-lossage "The result is a ~S, not a ~S."
- (type-specifier out-type)
- (type-specifier return-type)))))))
- (loop for arg in args
+ (let* ((nargs (length args))
+ (required (fun-type-required type))
+ (min-args (length required))
+ (optional (fun-type-optional type))
+ (max-args (+ min-args (length optional)))
+ (rest (fun-type-rest type))
+ (keyp (fun-type-keyp type)))
+ (cond
+ ((fun-type-wild-args type)
+ (loop for arg in args
+ and i from 1
+ do (check-arg-type arg *universal-type* i)))
+ ((not (or optional keyp rest))
+ (if (/= nargs min-args)
+ (note-lossage
+ "The function was called with ~R argument~:P, but wants exactly ~R."
+ nargs min-args)
+ (check-fixed-and-rest args required nil)))
+ ((< nargs min-args)
+ (note-lossage
+ "The function was called with ~R argument~:P, but wants at least ~R."
+ nargs min-args))
+ ((<= nargs max-args)
+ (check-fixed-and-rest args (append required optional) rest))
+ ((not (or keyp rest))
+ (note-lossage
+ "The function was called with ~R argument~:P, but wants at most ~R."
+ nargs max-args))
+ ((and keyp (oddp (- nargs max-args)))
+ (note-lossage
+ "The function has an odd number of arguments in the keyword portion."))
+ (t
+ (check-fixed-and-rest args (append required optional) rest)
+ (when keyp
+ (check-key-args args max-args type))))
+
+ (let* ((dtype (node-derived-type call))
+ (return-type (fun-type-returns type))
+ (out-type dtype))
+ (multiple-value-bind (int win) (funcall result-test out-type return-type)
+ (cond ((not win)
+ (note-unwinnage "can't tell whether the result is a ~S"
+ (type-specifier return-type)))
+ ((not int)
+ (note-lossage "The result is a ~S, not a ~S."
+ (type-specifier out-type)
+ (type-specifier return-type)))))))
+ (loop for arg in args
and i from 1
do (check-arg-type arg *wild-type* i)))
(cond (*lossage-detected* (values nil t))
- (*unwinnage-detected* (values nil nil))
- (t (values t t)))))
+ (*unwinnage-detected* (values nil nil))
+ (t (values t t)))))
;;; Check that the derived type of the continuation CONT is compatible
;;; with TYPE. N is the arg number, for error message purposes. We
:types (list val-type))))))))))))
type))
-;;; This is similar to VALID-FUNCTION-USE, but checks an
+;;; This is similar to VALID-FUN-USE, but checks an
;;; APPROXIMATE-FUN-TYPE against a real function type.
(declaim (ftype (function (approximate-fun-type fun-type
&optional function function function)
vars types)
(values vars (res))))
-;;; Check that the optional-dispatch OD conforms to Type. We return
+;;; Check that the optional-dispatch OD conforms to TYPE. We return
;;; the values of TRY-TYPE-INTERSECTIONS if there are no syntax
;;; problems, otherwise NIL, NIL.
;;;
(let* ((type-returns (fun-type-returns type))
(return (lambda-return (main-entry functional)))
(atype (when return
- (continuation-asserted-type (return-result return)))))
+ nil
+ #+nil(continuation-derived-type (return-result return))))) ; !!
(cond
((and atype (not (values-types-equal-or-intersect atype
type-returns)))
(t
(setf (leaf-type var) type)
(dolist (ref (leaf-refs var))
- (derive-node-type ref type)))))
+ (derive-node-type ref (make-single-value-type type))))))
t))))))
(defun assert-global-function-definition-type (name fun)
use EQ comparison)~@:>"
(continuation-source tag)
(type-specifier (continuation-type tag))))))
+
+(defun %compile-time-type-error (values atype dtype)
+ (declare (ignore dtype))
+ (error 'values-type-error :datum values :expected-type atype))
+
+(defoptimizer (%compile-time-type-error ir2-convert)
+ ((objects atype dtype) node block)
+ (let ((*compiler-error-context* node))
+ (setf (node-source-path node)
+ (cdr (node-source-path node)))
+ (destructuring-bind (values atype dtype)
+ (basic-combination-args node)
+ (declare (ignore values))
+ (let ((atype (continuation-value atype))
+ (dtype (continuation-value dtype)))
+ (unless (eq atype nil)
+ (compiler-warn
+ "Asserted type ~S conflicts with derived type ~S."
+ atype dtype))))
+ (ir2-convert-full-call node block)))
(barf "IF not at block end: ~S" node)))
(cset
(check-dest (set-value node) node))
+ (cast
+ (check-dest (cast-value node) node))
(bind
(check-fun-reached (bind-lambda node) node))
(creturn
((exit-entry node)
(format t "exit <no value>"))
(t
- (format t "exit <degenerate>"))))))
+ (format t "exit <degenerate>")))))
+ (cast
+ (let ((value (cast-value node)))
+ (format t "cast c~D ~A[~S -> ~S]" (cont-num value)
+ (if (cast-%type-check node) #\+ #\-)
+ (cast-type-to-check node)
+ (cast-asserted-type node)))))
(pprint-newline :mandatory)
(when (eq node last) (return)))))
(setf (block-number block) (incf num))
(setf (block-delete-p block) t)))
(do-blocks (block component)
- (unless (block-flag block)
+ (when (block-delete-p block)
(delete-block block))))
(values))
(defknown %%primitive (t t &rest t) *)
(defknown %pop-values (t) t)
(defknown %type-check-error (t t) nil)
+
+;; FIXME: This function does not return, but due to the implementation
+;; of FILTER-CONTINUATION we cannot write it here.
+(defknown %compile-time-type-error (t t t) *)
+
(defknown %odd-key-args-error () nil)
(defknown %unknown-key-arg-error (t) nil)
(defknown (%ldb %mask-field) (bit-index bit-index integer) unsigned-byte
(define-primitive-object (array :lowtag other-pointer-lowtag
:widetag t)
+ ;; FILL-POINTER of an ARRAY is in the same place as LENGTH of a
+ ;; VECTOR -- see SHRINK-VECTOR.
(fill-pointer :type index
:ref-trans %array-fill-pointer
:ref-known (flushable foldable)
(define-primitive-object (vector :type vector
:lowtag other-pointer-lowtag
:widetag t)
+ ;; FILL-POINTER of an ARRAY is in the same place as LENGTH of a
+ ;; VECTOR -- see SHRINK-VECTOR.
(length :ref-trans sb!c::vector-length
:type index)
(data :rest-p t :c-type #!-alpha "unsigned long" #!+alpha "u32"))
;; (Note that the following test on INFO catches KEYWORDs as well as
;; explicitly DEFCONSTANT symbols.)
(symbol (eq (info :variable :kind object) :constant))
- (list (eq (car object) 'quote))
+ (list (and (eq (car object) 'quote)
+ (consp (cdr object))))
(t t)))
+(defun constant-form-value (form)
+ (typecase form
+ (symbol (info :variable :constant-value form))
+ ((cons (eql quote) cons)
+ (second form))
+ (t form)))
+
(declaim (ftype (function (symbol &optional (or null sb!c::lexenv))) sb!xc:macro-function))
(defun sb!xc:macro-function (symbol &optional env)
#!+sb-doc
(reference-constant start cont thing))
\f
;;;; FUNCTION and NAMED-LAMBDA
-
-(def-ir1-translator function ((thing) start cont)
- #!+sb-doc
- "FUNCTION Name
- Return the lexically apparent definition of the function Name. Name may also
- be a lambda expression."
+(defun fun-name-leaf (thing)
(if (consp thing)
(cond
((member (car thing)
'(lambda named-lambda instance-lambda lambda-with-lexenv))
- (reference-leaf start
- cont
- (ir1-convert-lambdalike
+ (ir1-convert-lambdalike
thing
:debug-name (debug-namify "#'~S" thing)
- :allow-debug-catch-tag t)))
+ :allow-debug-catch-tag t))
((legal-fun-name-p thing)
- (let ((var (find-lexically-apparent-fun
- thing "as the argument to FUNCTION")))
- (reference-leaf start cont var)))
+ (find-lexically-apparent-fun
+ thing "as the argument to FUNCTION"))
(t
(compiler-error "~S is not a legal function name." thing)))
- (let ((var (find-lexically-apparent-fun
- thing "as the argument to FUNCTION")))
- (reference-leaf start cont var))))
+ (find-lexically-apparent-fun
+ thing "as the argument to FUNCTION")))
+
+(def-ir1-translator function ((thing) start cont)
+ #!+sb-doc
+ "FUNCTION Name
+ Return the lexically apparent definition of the function Name. Name may also
+ be a lambda expression."
+ (reference-leaf start cont (fun-name-leaf thing)))
\f
;;;; FUNCALL
,@arg-names))))
(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)
- (lexenv-policy *lexenv*))
- (ir1-convert-combination-args fun-cont cont args)))
+ (if (and (consp function) (eq (car function) 'function))
+ (ir1-convert start cont `(,(fun-name-leaf (second function)) ,@args))
+ (let ((fun-cont (make-continuation)))
+ (ir1-convert start fun-cont `(the function ,function))
+ (ir1-convert-combination-args fun-cont cont args))))
;;; This source transform exists to reduce the amount of work for the
;;; compiler. If the called function is a FUNCTION form, then convert
(declare (type list body) (type continuation start cont))
(multiple-value-bind (forms decls) (parse-body body nil)
(let ((*lexenv* (process-decls decls vars funs cont)))
- (ir1-convert-aux-bindings start cont forms nil nil))))
+ (ir1-convert-progn-body start cont forms))))
(def-ir1-translator locally ((&body body) start cont)
#!+sb-doc
\f
;;;; the THE special operator, and friends
-;;; Do stuff to recognize a THE or VALUES declaration. CONT is the
-;;; continuation that the assertion applies to, TYPE is the type
-;;; specifier and LEXENV is the current lexical environment. NAME is
-;;; the name of the declaration we are doing, for use in error
-;;; messages.
-;;;
-;;; This is somewhat involved, since a type assertion may only be made
-;;; on a continuation, not on a node. We can't just set the
-;;; continuation asserted type and let it go at that, since there may
-;;; be parallel THE's for the same continuation, i.e.
-;;; (if ...
-;;; (the foo ...)
-;;; (the bar ...))
-;;;
-;;; In this case, our representation can do no better than the union
-;;; of these assertions. And if there is a branch with no assertion,
-;;; we have nothing at all. We really need to recognize scoping, since
-;;; we need to be able to discern between parallel assertions (which
-;;; we union) and nested ones (which we intersect).
-;;;
-;;; We represent the scoping by throwing our innermost (intersected)
-;;; assertion on CONT into the TYPE-RESTRICTIONS. As we go down, we
-;;; intersect our assertions together. If CONT has no uses yet, we
-;;; have not yet bottomed out on the first COND branch; in this case
-;;; we optimistically assume that this type will be the one we end up
-;;; with, and set the ASSERTED-TYPE to it. We can never get better
-;;; than the type that we have the first time we bottom out. Later
-;;; THE's (or the absence thereof) can only weaken this result.
-;;;
-;;; We make this work by getting USE-CONTINUATION to do the unioning
-;;; across COND branches. We can't do it here, since we don't know how
-;;; many branches there are going to be.
-(defun ir1ize-the-or-values (type cont lexenv place)
- (declare (type continuation cont) (type lexenv lexenv))
- (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-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?
- (not (policy *lexenv*
- (= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
- (compiler-warn
- "The type ~S ~A conflicts with an enclosing assertion:~% ~S"
- (type-specifier atype)
- place
- (type-specifier old-atype)))
- (make-lexenv :type-restrictions `((,cont . ,new-atype))
- :weakend-type-restrictions `((,cont . ,new-ctype))
- :default lexenv)))
+;;; A logic shared among THE and TRULY-THE.
+(defun the-in-policy (type value policy start cont)
+ (let ((type (if (ctype-p type) type
+ (compiler-values-specifier-type type))))
+ (cond ((or (eq type *wild-type*)
+ (eq type *universal-type*)
+ (and (leaf-p value)
+ (values-subtypep (make-single-value-type (leaf-type value))
+ type))
+ (and (sb!xc:constantp value)
+ (ctypep (constant-form-value value)
+ (single-value-type type))))
+ (ir1-convert start cont value))
+ (t (let ((value-cont (make-continuation)))
+ (ir1-convert start value-cont value)
+ (let ((cast (make-cast value-cont type policy)))
+ (link-node-to-previous-continuation cast value-cont)
+ (setf (continuation-dest value-cont) cast)
+ (use-continuation cast cont)))))))
;;; Assert that FORM evaluates to the specified type (which may be a
-;;; VALUES type).
+;;; VALUES type). TYPE may be a type specifier or (as a hack) a CTYPE.
;;;
;;; FIXME: In a version of CMU CL that I used at Cadabra ca. 20000101,
;;; this didn't seem to expand into an assertion, at least for ALIEN
;;; values. Check that SBCL doesn't have this problem.
(def-ir1-translator the ((type value) start cont)
- (with-continuation-type-assertion (cont (compiler-values-specifier-type type)
- "in THE declaration")
- (ir1-convert start cont value)))
+ (the-in-policy type value (lexenv-policy *lexenv*) start cont))
;;; This is like the THE special form, except that it believes
;;; whatever you tell it. It will never generate a type check, but
;;; will cause a warning if the compiler can prove the assertion is
;;; wrong.
-;;;
-;;; Since the CONTINUATION-DERIVED-TYPE is computed as the union of
-;;; its uses's types, setting it won't work. Instead we must intersect
-;;; the type with the uses's DERIVED-TYPE.
(def-ir1-translator truly-the ((type value) start cont)
#!+sb-doc
+ ""
(declare (inline member))
- (let ((type (compiler-values-specifier-type type))
+ #-nil
+ (let ((type (coerce-to-values (compiler-values-specifier-type type)))
(old (find-uses cont)))
(ir1-convert start cont value)
(do-uses (use cont)
(unless (member use old :test #'eq)
- (derive-node-type use type)))))
+ (derive-node-type use type))))
+ #+nil
+ (the-in-policy type value '((type-check . 0)) start cont))
\f
;;;; SETQ
(setq-var start cont leaf (second things)))
(cons
(aver (eq (car leaf) 'MACRO))
+ ;; FIXME: [Free] type declaration. -- APD, 2002-01-26
(ir1-convert start cont `(setf ,(cdr leaf) ,(second things))))
(heap-alien-info
(ir1-convert start cont
;;; This should only need to be called in SETQ.
(defun setq-var (start cont var value)
(declare (type continuation start cont) (type basic-var var))
- (let ((dest (make-continuation)))
- (ir1-convert start dest value)
- (assert-continuation-type dest
- (or (lexenv-find var type-restrictions)
- (leaf-type var))
- (lexenv-policy *lexenv*))
+ (let ((dest (make-continuation))
+ (type (or (lexenv-find var type-restrictions)
+ (leaf-type var))))
+ (ir1-convert start dest `(the ,type ,value))
(let ((res (make-set :var var :value dest)))
(setf (continuation-dest dest) res)
(setf (leaf-ever-used var) t)
(continuation-starts-block dummy-start)
(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))
+ (substitute-continuation-uses cont dummy-start)
(continuation-starts-block dummy-result)
(ir1-convert-progn-body dummy-start dummy-result forms)
;;; constant leaf.
(defun constant-continuation-p (thing)
(and (continuation-p thing)
- (let ((use (continuation-use thing)))
- (and (ref-p use)
- (constant-p (ref-leaf use))))))
+ (let ((use (principal-continuation-use thing)))
+ (and (ref-p use) (constant-p (ref-leaf use))))))
;;; Return the constant value for a continuation whose only use is a
;;; constant node.
(declaim (ftype (function (continuation) t) continuation-value))
(defun continuation-value (cont)
- (aver (constant-continuation-p cont))
- (constant-value (ref-leaf (continuation-use cont))))
+ (let ((use (principal-continuation-use cont)))
+ (constant-value (ref-leaf use))))
\f
;;;; interface for obtaining results of type inference
-;;; Return a (possibly values) type that describes what we have proven
-;;; about the type of Cont without taking any type assertions into
-;;; consideration. This is just the union of the NODE-DERIVED-TYPE of
-;;; all the uses. Most often people use CONTINUATION-DERIVED-TYPE or
-;;; CONTINUATION-TYPE instead of using this function directly.
-(defun continuation-proven-type (cont)
- (declare (type continuation cont))
- (ecase (continuation-kind cont)
- ((:block-start :deleted-block-start)
- (let ((uses (block-start-uses (continuation-block cont))))
- (if uses
- (do ((res (node-derived-type (first uses))
- (values-type-union (node-derived-type (first current))
- res))
- (current (rest uses) (rest current)))
- ((null current) res))
- *empty-type*)))
- (:inside-block
- (node-derived-type (continuation-use cont)))))
-
;;; Our best guess for the type of this continuation's value. Note
;;; that this may be VALUES or FUNCTION type, which cannot be passed
;;; as an argument to the normal type operations. See
;;;
;;; What we do is call CONTINUATION-PROVEN-TYPE and check whether the
;;; result is a subtype of the assertion. If so, return the proven
-;;; type and set TYPE-CHECK to nil. Otherwise, return the intersection
+;;; type and set TYPE-CHECK to NIL. Otherwise, return the intersection
;;; of the asserted and proven types, and set TYPE-CHECK T. If
;;; TYPE-CHECK already has a non-null value, then preserve it. Only in
;;; the somewhat unusual circumstance of a newly discovered assertion
(defun continuation-derived-type (cont)
(declare (type continuation cont))
(or (continuation-%derived-type cont)
- (%continuation-derived-type cont)))
+ (setf (continuation-%derived-type cont)
+ (%continuation-derived-type cont))))
(defun %continuation-derived-type (cont)
(declare (type continuation cont))
- (let ((proven (continuation-proven-type cont))
- (asserted (continuation-asserted-type cont)))
- (cond ((values-subtypep proven asserted)
- (setf (continuation-%type-check cont) nil)
- (setf (continuation-%derived-type cont) proven))
- ((and (values-subtypep proven (specifier-type 'function))
- (values-subtypep asserted (specifier-type 'function)))
- ;; It's physically impossible for a runtime type check to
- ;; distinguish between the various subtypes of FUNCTION, so
- ;; it'd be pointless to do more type checks here.
- (setf (continuation-%type-check cont) nil)
- (setf (continuation-%derived-type cont)
- ;; FIXME: This should depend on optimization
- ;; policy. This is for SPEED > SAFETY:
- #+nil (values-type-intersection asserted proven)
- ;; and this is for SAFETY >= SPEED:
- #-nil proven))
- (t
- (unless (or (continuation-%type-check cont)
- (not (continuation-dest cont))
- (eq asserted *universal-type*))
- (setf (continuation-%type-check cont) t))
-
- (setf (continuation-%derived-type cont)
- (values-type-intersection asserted proven))))))
-
-;;; Call CONTINUATION-DERIVED-TYPE to make sure the slot is up to
-;;; date, then return it.
-#!-sb-fluid (declaim (inline continuation-type-check))
-(defun continuation-type-check (cont)
- (declare (type continuation cont))
- (continuation-derived-type cont)
- (continuation-%type-check cont))
+ (ecase (continuation-kind cont)
+ ((:block-start :deleted-block-start)
+ (let ((uses (block-start-uses (continuation-block cont))))
+ (if uses
+ (do ((res (node-derived-type (first uses))
+ (values-type-union (node-derived-type (first current))
+ res))
+ (current (rest uses) (rest current)))
+ ((null current) res))
+ *empty-type*)))
+ (:inside-block
+ (node-derived-type (continuation-use cont)))))
;;; Return the derived type for CONT's first value. This is guaranteed
;;; not to be a VALUES or FUNCTION type.
-(declaim (ftype (function (continuation) ctype) continuation-type))
+(declaim (ftype (sfunction (continuation) ctype) continuation-type))
(defun continuation-type (cont)
(single-value-type (continuation-derived-type cont)))
and type of-type ctype in arg-types
do (when arg
(setf (continuation-%externally-checkable-type arg)
- type)))
+ (coerce-to-values type))))
(continuation-%externally-checkable-type cont)))))))
+(declaim (inline flush-continuation-externally-checkable-type))
+(defun flush-continuation-externally-checkable-type (cont)
+ (declare (type continuation cont))
+ (setf (continuation-%externally-checkable-type cont) nil))
\f
;;;; interface routines used by optimizers
;;; careful not to fly into space when the DEST's PREV is missing.
(defun reoptimize-continuation (cont)
(declare (type continuation cont))
+ (setf (continuation-%derived-type cont) nil)
(unless (member (continuation-kind cont) '(:deleted :unused))
- (setf (continuation-%derived-type cont) nil)
(let ((dest (continuation-dest cont)))
(when dest
(setf (continuation-reoptimize cont) t)
(setf (block-type-check (node-block node)) t)))
(values))
+(defun reoptimize-continuation-uses (cont)
+ (declare (type continuation cont))
+ (dolist (use (find-uses cont))
+ (setf (node-reoptimize use) t)
+ (setf (block-reoptimize (node-block use)) t)
+ (setf (component-reoptimize (node-component use)) t)))
+
;;; 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
(declare (type node node) (type ctype rtype))
(let ((node-type (node-derived-type node)))
(unless (eq node-type rtype)
- (let ((int (values-type-intersection node-type rtype)))
+ (let ((int (values-type-intersection node-type rtype))
+ (cont (node-cont node)))
(when (type/= node-type int)
(when (and *check-consistency*
(eq int *empty-type*)
(type-specifier rtype) (type-specifier node-type))))
(setf (node-derived-type node) int)
(when (and (ref-p node)
- (member-type-p int)
- (null (rest (member-type-members int)))
(lambda-var-p (ref-leaf node)))
- (change-ref-leaf node (find-constant (first (member-type-members int)))))
- (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)))
+ (let ((type (single-value-type int)))
+ (when (and (member-type-p type)
+ (null (rest (member-type-members type))))
+ (change-ref-leaf node (find-constant
+ (first (member-type-members type)))))))
+ (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.
+;;; error for CONT's value not to be TYPEP to TYPE. We implement it
+;;; moving uses behind a new CAST node. 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 policy)
(declare (type continuation cont) (type ctype type))
- (when (eq type *wild-type*)
+ (when (values-subtypep (continuation-derived-type cont) type)
(return-from assert-continuation-type))
- (set-continuation-type-assertion cont type (maybe-weaken-check type policy)))
+ (let* ((dest (continuation-dest cont))
+ (prev-cont (node-prev dest)))
+ (aver dest)
+ (with-ir1-environment-from-node dest
+ (let* ((cast (make-cast cont type policy))
+ (checked-value (make-continuation)))
+ (setf (continuation-next prev-cont) cast
+ (node-prev cast) prev-cont)
+ (use-continuation cast checked-value)
+ (link-node-to-previous-continuation dest checked-value)
+ (substitute-continuation checked-value cont)
+ (setf (continuation-dest cont) cast)
+ (reoptimize-continuation cont)))))
;;; 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
(t
(loop
(let ((succ (block-succ block)))
- (unless (and succ (null (rest succ)))
+ (unless (singleton-p succ)
(return)))
(let ((last (block-last block)))
(typecase last
(cif
- (if (memq (continuation-type-check (if-test last))
- '(nil :deleted))
- ;; FIXME: Remove the test above when the bug 203
- ;; will be fixed.
- (progn
- (flush-dest (if-test last))
- (when (unlink-node last)
- (return)))
- (return)))
+ (flush-dest (if-test last))
+ (when (unlink-node last)
+ (return)))
(exit
(when (maybe-delete-exit last)
(return)))))
(aver (not (block-delete-p block)))
(ir1-optimize-block block))
- (cond ((block-delete-p block)
+ (cond ((and (block-delete-p block) (block-component block))
(delete-block block))
((and (block-flush-p block) (block-component block))
(flush-dead-code block))))))
(when value
(derive-node-type node (continuation-derived-type value)))))
(cset
- (ir1-optimize-set node)))))
+ (ir1-optimize-set node))
+ (cast
+ (ir1-optimize-cast node)))))
(values))
(defun join-successor-if-possible (block)
(declare (type cblock block))
(let ((next (first (block-succ block))))
- (when (block-start next)
+ (when (block-start next) ; NEXT is not an END-OF-COMPONENT marker
(let* ((last (block-last block))
(last-cont (node-cont last))
(next-cont (block-start next)))
;; The successor has more than one predecessor.
(rest (block-pred next))
;; The last node's CONT is also used somewhere else.
+ ;; (as in (IF <cond> (M-V-PROG1 ...) (M-V-PROG1 ...)))
(not (eq (continuation-use last-cont) last))
;; The successor is the current block (infinite loop).
(eq next block)
(block-home-lambda next))))
nil)
;; Joining is easy when the successor's START
- ;; continuation is the same from our LAST's CONT.
+ ;; continuation is the same from our LAST's CONT.
((eq last-cont next-cont)
(join-blocks block next)
t)
;; If they differ, then we can still join when the last
;; continuation has no next and the next continuation
- ;; has no uses.
+ ;; has no uses.
((and (null (block-start-uses next))
(eq (continuation-kind last-cont) :inside-block))
;; In this case, we replace the next
(setf (block-start next) last-cont)
(join-blocks block next))
t)
+ ((and (null (block-start-uses next))
+ (not (exit-p (continuation-dest last-cont)))
+ (null (continuation-lexenv-uses last-cont)))
+ (assert (null (find-uses next-cont)))
+ (when (continuation-dest last-cont)
+ (substitute-continuation next-cont last-cont))
+ (delete-continuation-use last)
+ (add-continuation-use last next-cont)
+ (setf (continuation-%derived-type next-cont) nil)
+ (join-blocks block next)
+ t)
(t
nil))))))
;; functional args to determine if they have
;; any side effects.
(if (policy node (= safety 3))
- (and (ir1-attributep attr flushable)
- (every (lambda (arg)
- ;; FIXME: when bug 203
- ;; will be fixed, remove
- ;; this check
- (member (continuation-type-check arg)
- '(nil :deleted)))
- (basic-combination-args node))
- (valid-fun-use node
- (info :function :type
- (leaf-source-name (ref-leaf (continuation-use (basic-combination-fun node)))))
- :result-test #'always-subtypep
- :lossage-fun nil
- :unwinnage-fun nil))
+ (ir1-attributep attr flushable)
(ir1-attributep attr unsafely-flushable)))
(flush-combination node))))))
(mv-combination
(flush-dest (set-value node))
(setf (basic-var-sets var)
(delete node (basic-var-sets var)))
- (unlink-node node)))))))
+ (unlink-node node))))
+ (cast
+ (unless (cast-type-check node)
+ (flush-dest (cast-value node))
+ (unlink-node node))))))
(setf (block-flush-p block) nil)
(values))
(return-from find-result-type (values)))))
(t
(use-union (node-derived-type use)))))
- (let ((int (values-type-intersection
- (continuation-asserted-type result)
- (use-union))))
+ (let ((int
+ ;; (values-type-intersection
+ ;; (continuation-asserted-type result) ; FIXME -- APD, 2002-01-26
+ (use-union)
+ ;; )
+ ))
(setf (return-result-type node) int))))
(values))
(convert-if-if use node)
(when (continuation-use test) (return)))))
- (when (memq (continuation-type-check test)
- '(nil :deleted))
- ;; FIXME: Remove the test above when the bug 203 will be fixed.
- (let* ((type (continuation-type test))
- (victim
- (cond ((constant-continuation-p test)
- (if (continuation-value test)
- (if-alternative node)
- (if-consequent node)))
- ((not (types-equal-or-intersect type (specifier-type 'null)))
- (if-alternative node))
- ((type= type (specifier-type 'null))
- (if-consequent node)))))
- (when victim
- (flush-dest test)
- (when (rest (block-succ block))
- (unlink-blocks block victim))
- (setf (component-reanalyze (node-component node)) t)
- (unlink-node node)))))
+ (let* ((type (continuation-type test))
+ (victim
+ (cond ((constant-continuation-p test)
+ (if (continuation-value test)
+ (if-alternative node)
+ (if-consequent node)))
+ ((not (types-equal-or-intersect type (specifier-type 'null)))
+ (if-alternative node))
+ ((type= type (specifier-type 'null))
+ (if-consequent node)))))
+ (when victim
+ (flush-dest test)
+ (when (rest (block-succ block))
+ (unlink-blocks block victim))
+ (setf (component-reanalyze (node-component node)) t)
+ (unlink-node node))))
(values))
;;; Create a new copy of an IF node that tests the value of the node
(new-block (continuation-starts-block new-cont)))
(link-node-to-previous-continuation new-node new-cont)
(setf (continuation-dest new-cont) new-node)
- (setf (continuation-%externally-checkable-type new-cont) nil)
+ (flush-continuation-externally-checkable-type new-cont)
(add-continuation-use new-node dummy-cont)
(setf (block-last new-block) new-node)
(declare (type exit node))
(let ((value (exit-value node))
(entry (exit-entry node))
- (cont (node-cont node)))
+ (cont (node-cont node)))
(when (and entry
(eq (node-home-lambda node) (node-home-lambda entry)))
(setf (entry-exits entry) (delete node (entry-exits entry)))
- (prog1
- (unlink-node node)
- (when value
- (collect ((merges))
- (when (return-p (continuation-dest cont))
- (do-uses (use value)
- (when (and (basic-combination-p use)
- (eq (basic-combination-kind use) :local))
- (merges use))))
- (substitute-continuation-uses cont value)
- (dolist (merge (merges))
- (merge-tail-sets merge))))))))
+ (if value
+ (delete-filter node cont value)
+ (unlink-node node)))))
+
\f
;;;; combination IR1 optimization
(when fun
(let ((res (funcall fun node)))
(when res
- (derive-node-type node res)
+ (derive-node-type node (coerce-to-values res))
(maybe-terminate-block node nil)))))
(let ((fun (fun-info-optimizer kind)))
(unless (and fun (funcall fun node))
(dolist (x (fun-info-transforms kind))
- #!+sb-show
+ #!+sb-show
(when *show-transforms-p*
(let* ((cont (basic-combination-fun node))
(fname (continuation-fun-name cont t)))
(values))
-;;; If CALL is to a function that doesn't return (i.e. return type is
-;;; NIL), then terminate the block there, and link it to the component
-;;; tail. We also change the call's CONT to be a dummy continuation to
-;;; prevent the use from confusing things.
+;;; If NODE doesn't return (i.e. return type is NIL), then terminate
+;;; the block there, and link it to the component tail. We also change
+;;; the NODE's CONT to be a dummy continuation to prevent the use from
+;;; confusing things.
;;;
;;; Except when called during IR1 [FIXME: What does this mean? Except
;;; during IR1 conversion? What about IR1 optimization?], we delete
;;; the continuation if it has no other uses. (If it does have other
;;; uses, we reoptimize.)
;;;
-;;; Termination on the basis of a continuation type assertion is
+;;; Termination on the basis of a continuation type is
;;; inhibited when:
;;; -- The continuation is deleted (hence the assertion is spurious), or
;;; -- We are in IR1 conversion (where THE assertions are subject to
;;; weakening.)
-(defun maybe-terminate-block (call ir1-converting-not-optimizing-p)
- (declare (type basic-combination call))
- (let* ((block (node-block call))
- (cont (node-cont call))
+(defun maybe-terminate-block (node ir1-converting-not-optimizing-p)
+ (declare (type (or basic-combination cast) node))
+ (let* ((block (node-block node))
+ (cont (node-cont node))
(tail (component-tail (block-component block)))
(succ (first (block-succ block))))
- (unless (or (and (eq call (block-last block)) (eq succ tail))
+ (unless (or (and (eq node (block-last block)) (eq succ tail))
(block-delete-p block))
- (when (or (and (eq (continuation-asserted-type cont) *empty-type*)
- (not (or ir1-converting-not-optimizing-p
- (eq (continuation-kind cont) :deleted))))
- (eq (node-derived-type call) *empty-type*))
+ (when (or (and (not (or ir1-converting-not-optimizing-p
+ (eq (continuation-kind cont) :deleted)))
+ (eq (continuation-derived-type cont) *empty-type*))
+ (eq (node-derived-type node) *empty-type*))
(cond (ir1-converting-not-optimizing-p
- (delete-continuation-use call)
+ (delete-continuation-use node)
(cond
((block-last block)
- (aver (and (eq (block-last block) call)
+ (aver (and (eq (block-last block) node)
(eq (continuation-kind cont) :block-start))))
(t
- (setf (block-last block) call)
+ (setf (block-last block) node)
(link-blocks block (continuation-starts-block cont)))))
(t
- (node-ends-block call)
- (delete-continuation-use call)
+ (node-ends-block node)
+ (delete-continuation-use node)
(if (eq (continuation-kind cont) :unused)
(delete-continuation cont)
(reoptimize-continuation cont))))
-
+
(unlink-blocks block (first (block-succ block)))
(setf (component-reanalyze (block-component block)) t)
(aver (not (block-succ block)))
(link-blocks block tail)
- (add-continuation-use call (make-continuation))
+ (add-continuation-use node (make-continuation))
t))))
;;; This is called both by IR1 conversion and IR1 optimization when
predicate)
(let ((dest (continuation-dest (node-cont call))))
(and dest (not (if-p dest)))))))
- ;; FIXME: This SYMBOLP is part of a literal
- ;; translation of a test in the old CMU CL
- ;; source, and it's not quite clear what
- ;; the old source meant. Did it mean "has a
- ;; valid name"? Or did it mean "is an
- ;; ordinary function name, not a SETF
- ;; function"? Either way, the old CMU CL
- ;; code probably didn't deal with SETF
- ;; functions correctly, and neither does
- ;; this new SBCL code, and that should be fixed.
- (when (symbolp (leaf-source-name leaf))
- (let ((dummies (make-gensym-list
- (length (combination-args call)))))
- (transform-call call
- `(lambda ,dummies
- (,(leaf-source-name leaf)
- ,@dummies))
- (leaf-source-name leaf))))))))))
+ (let ((name (leaf-source-name leaf))
+ (dummies (make-gensym-list
+ (length (combination-args call)))))
+ (transform-call call
+ `(lambda ,dummies
+ (,@(if (symbolp name)
+ `(,name)
+ `(funcall #',name))
+ ,@dummies))
+ (leaf-source-name leaf)))))))))
(values))
\f
;;;; known function optimization
(policy node (> speed inhibit-warnings))))
(*compiler-error-context* node))
(cond ((or (not constrained)
- (valid-fun-use node type :strict-result t))
+ (valid-fun-use node type))
(multiple-value-bind (severity args)
(catch 'give-up-ir1-transform
(transform-call node
(when (type/= int var-type)
(setf (leaf-type leaf) int)
(dolist (ref (leaf-refs leaf))
- (derive-node-type ref int))))
+ (derive-node-type ref (make-single-value-type int))
+ (let* ((cont (node-cont ref))
+ (dest (continuation-dest cont)))
+ ;; KLUDGE: LET var substitution
+ (when (combination-p dest)
+ (reoptimize-continuation cont))))))
(values))))
;;; Figure out the type of a LET variable that has sets. We compute
(let ((type (continuation-type (set-value set))))
(res type)
(when (node-reoptimize set)
- (derive-node-type set type)
+ (derive-node-type set (make-single-value-type type))
(setf (node-reoptimize set) nil))))
(propagate-to-refs var (res)))
(values))
(setf (continuation-reoptimize iv) nil)
(propagate-from-sets var (continuation-type iv)))))))
- (derive-node-type node (continuation-type (set-value node)))
+ (derive-node-type node (make-single-value-type
+ (continuation-type (set-value node))))
(values))
;;; Return true if the value of REF will always be the same (and is
;;; replace the variable reference's CONT with the arg continuation.
;;; This is inhibited when:
;;; -- CONT has other uses, or
-;;; -- CONT receives multiple values, or
;;; -- the reference is in a different environment from the variable, or
-;;; -- either continuation has a funky TYPE-CHECK annotation.
-;;; -- the continuations have incompatible assertions, so the new asserted type
-;;; would be NIL.
-;;; -- the VAR's DEST has a different policy than the ARG's (think safety).
+;;; -- CONT carries unknown number of values, or
+;;; -- DEST is return or exit, or
+;;; -- DEST is sensitive to the number of values and ARG return non-one value.
;;;
;;; We change the REF to be a reference to NIL with unused value, and
;;; let it be flushed as dead code. A side effect of this substitution
(declare (type continuation arg) (type lambda-var var))
(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
- (continuation-single-value-p cont)
+ (typecase dest
+ (cast
+ (and (type-single-value-p (continuation-derived-type arg))
+ (multiple-value-bind (pdest pprev)
+ (principal-continuation-end cont)
+ (declare (ignore pdest))
+ (continuation-single-value-p pprev))))
+ (mv-combination
+ (or (eq (basic-combination-fun dest) cont)
+ (and (eq (basic-combination-kind dest) :local)
+ (type-single-value-p (continuation-derived-type arg)))))
+ ((or creturn exit)
+ nil)
+ (t
+ ;; (AVER (CONTINUATION-SINGLE-VALUE-P CONT))
+ t))
(eq (node-home-lambda ref)
- (lambda-home (lambda-var-home var)))
- (member (continuation-type-check arg) '(t nil))
- (member (continuation-type-check cont) '(t nil))
- (not (eq (values-type-intersection
- cont-atype
- (continuation-asserted-type arg))
- *empty-type*))
- (eq (lexenv-policy (node-lexenv dest))
- (lexenv-policy (node-lexenv (continuation-dest arg)))))
+ (lambda-home (lambda-var-home var))))
(aver (member (continuation-kind arg)
'(:block-start :deleted-block-start :inside-block)))
- (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)
;;; derived-type information for the arg to all the VAR's refs.
;;;
;;; Substitution is inhibited when the arg leaf's derived type isn't a
-;;; subtype of the argument's asserted type. This prevents type
-;;; checking from being defeated, and also ensures that the best
-;;; representation for the variable can be used.
+;;; subtype of the argument's leaf type. This prevents type checking
+;;; from being defeated, and also ensures that the best representation
+;;; for the variable can be used.
;;;
;;; Substitution of individual references is inhibited if the
;;; reference is in a different component from the home. This can only
(when (ref-p use)
(let ((leaf (ref-leaf use)))
(when (and (constant-reference-p use)
- (values-subtypep (leaf-type leaf)
- (continuation-asserted-type arg)))
+ (csubtypep (leaf-type leaf)
+ ;; (NODE-DERIVED-TYPE USE) would
+ ;; be better -- APD, 2003-05-15
+ (leaf-type var)))
(propagate-to-refs var (continuation-type arg))
(let ((use-component (node-component use)))
(substitute-leaf-if
leaf var))
t)))))
((and (null (rest (leaf-refs var)))
- (substitute-single-use-continuation arg var)))
+ (substitute-single-use-continuation arg var)))
(t
(propagate-to-refs var (continuation-type arg))))))
- (when (every #'null (combination-args call))
+ (when (every #'not (combination-args call))
(delete-let fun))
(values))
(propagate-from-sets var type)
(propagate-to-refs var type)))
vars
- (append types
- (make-list (max (- (length vars) nvals) 0)
- :initial-element (specifier-type 'null))))))
+ (adjust-list types
+ (length vars)
+ (specifier-type 'null)))))
(setf (continuation-reoptimize arg) nil))
(values))
(args (basic-combination-args node)))
(unless (and (ref-p ref) (constant-reference-p ref)
- args (null (rest args)))
+ (singleton-p args))
(return-from ir1-optimize-mv-call))
(multiple-value-bind (min max)
(let ((fun-cont (basic-combination-fun call)))
(setf (continuation-dest fun-cont) use)
(setf (combination-fun use) fun-cont)
- (setf (continuation-%externally-checkable-type fun-cont) nil))
+ (flush-continuation-externally-checkable-type fun-cont))
(setf (combination-kind use) :local)
(setf (functional-kind fun) :let)
(flush-dest (first (basic-combination-args call)))
(let ((args (combination-args use)))
(dolist (arg args)
(setf (continuation-dest arg) node)
- (setf (continuation-%externally-checkable-type arg) nil))
+ (flush-continuation-externally-checkable-type arg))
(setf (combination-args use) nil)
(flush-dest list)
(setf (combination-args node) args))
(declare (ignore ,@dummies))
val))
nil))
+
+;;; TODO:
+;;; - CAST chains;
+(defun ir1-optimize-cast (cast &optional do-not-optimize)
+ (declare (type cast cast))
+ (let* ((value (cast-value cast))
+ (value-type (continuation-derived-type value))
+ (atype (cast-asserted-type cast))
+ (int (values-type-intersection value-type atype)))
+ (derive-node-type cast int)
+ (when (eq int *empty-type*)
+ (unless (eq value-type *empty-type*)
+
+ ;; FIXME: Do it in one step.
+ (filter-continuation
+ value
+ `(multiple-value-call #'list 'dummy))
+ (filter-continuation
+ value
+ ;; FIXME: Derived type.
+ `(%compile-time-type-error 'dummy
+ ',(type-specifier (coerce-to-values atype))
+ ',(type-specifier value-type)))
+ ;; KLUDGE: FILTER-CONTINUATION does not work for
+ ;; non-returning functions, so we declare the return type of
+ ;; %COMPILE-TIME-TYPE-ERROR to be * and derive the real type
+ ;; here.
+ (derive-node-type (continuation-use value) *empty-type*)
+ (maybe-terminate-block (continuation-use value) nil)
+ ;; FIXME: Is it necessary?
+ (aver (null (block-pred (node-block cast))))
+ (setf (block-delete-p (node-block cast)) t)
+ (return-from ir1-optimize-cast)))
+ (when (eq (node-derived-type cast) *empty-type*)
+ (maybe-terminate-block cast nil))
+
+ (flet ((delete-cast ()
+ (let ((cont (node-cont cast)))
+ (delete-filter cast cont value)
+ (reoptimize-continuation cont)
+ (when (continuation-single-value-p cont)
+ (note-single-valuified-continuation cont))
+ (when (not (continuation-dest cont))
+ (reoptimize-continuation-uses cont)))))
+ (cond
+ ((and (not do-not-optimize)
+ (values-subtypep value-type
+ (cast-asserted-type cast)))
+ (delete-cast)
+ (return-from ir1-optimize-cast t))
+ ((and (cast-%type-check cast)
+ (values-subtypep value-type
+ (cast-type-to-check cast)))
+ (setf (cast-%type-check cast) nil)))))
+
+ (unless do-not-optimize
+ (setf (node-reoptimize cast) nil)))
;;; CONSTANT might be circular. We also check that the constant (and
;;; any subparts) are dumpable at all.
(eval-when (:compile-toplevel :load-toplevel :execute)
- ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD)
+ ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD)
;; below. -- AL 20010227
(def!constant list-to-hash-table-threshold 32))
(defun maybe-emit-make-load-forms (constant)
;;; our block and link it to that block. If the continuation is not
;;; currently used, then we set the DERIVED-TYPE for the continuation
;;; to that of the node, so that a little type propagation gets done.
-;;;
-;;; We also deal with a bit of THE's semantics here: we weaken the
-;;; assertion on CONT to be no stronger than the assertion on CONT in
-;;; our scope. See the IR1-CONVERT method for THE.
#!-sb-fluid (declaim (inline use-continuation))
(defun use-continuation (node cont)
(declare (type node node) (type continuation cont))
(error "~S is already a predecessor of ~S." node-block block))
(push node-block (block-pred block))
(add-continuation-use node cont)
- (unless (eq (continuation-asserted-type cont) *wild-type*)
- (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))))))
+ (reoptimize-continuation cont)))
\f
;;;; exported functions
(t
(reference-constant start cont form)))
(let ((opname (car form)))
- (cond ((symbolp opname)
- (let ((lexical-def (lexenv-find opname funs)))
+ (cond ((or (symbolp opname) (leaf-p opname))
+ (let ((lexical-def (if (leaf-p opname)
+ opname
+ (lexenv-find opname funs))))
(typecase lexical-def
(null (ir1-convert-global-functoid start cont form))
(functional
(when (producing-fasl-file)
(maybe-emit-make-load-forms value))
(let* ((leaf (find-constant value))
- (res (make-ref (leaf-type leaf) leaf)))
+ (res (make-ref leaf)))
(push res (leaf-refs leaf))
(link-node-to-previous-continuation res start)
(use-continuation res cont)))
(when (typep functional '(or optional-dispatch clambda))
;; When FUNCTIONAL knows its component
- (when (lambda-p functional)
+ (when (lambda-p functional)
(aver (eql (lambda-component functional) *current-component*)))
(pushnew functional
;;; functional instead.
(defun reference-leaf (start cont leaf)
(declare (type continuation start cont) (type leaf leaf))
- (with-continuation-type-assertion
- (cont (or (lexenv-find leaf type-restrictions) *wild-type*)
- "in DECLARE")
- (let* ((leaf (or (and (defined-fun-p leaf)
- (not (eq (defined-fun-inlinep leaf)
- :notinline))
- (let ((functional (defined-fun-functional leaf)))
- (when (and functional
- (not (functional-kind functional)))
- (maybe-reanalyze-functional functional))))
- leaf))
- (res (make-ref (leaf-type leaf)
- leaf)))
- (push res (leaf-refs leaf))
- (setf (leaf-ever-used leaf) t)
- (link-node-to-previous-continuation res start)
- (use-continuation res cont))))
+ (let* ((type (lexenv-find leaf type-restrictions))
+ (leaf (or (and (defined-fun-p leaf)
+ (not (eq (defined-fun-inlinep leaf)
+ :notinline))
+ (let ((functional (defined-fun-functional leaf)))
+ (when (and functional
+ (not (functional-kind functional)))
+ (maybe-reanalyze-functional functional))))
+ leaf))
+ (ref (make-ref leaf)))
+ (push ref (leaf-refs leaf))
+ (setf (leaf-ever-used leaf) t)
+ (link-node-to-previous-continuation ref start)
+ (cond (type (let* ((ref-cont (make-continuation))
+ (cast (make-cast ref-cont
+ (make-single-value-type type)
+ (lexenv-policy *lexenv*))))
+ (setf (continuation-dest ref-cont) cast)
+ (use-continuation ref ref-cont)
+ (link-node-to-previous-continuation cast ref-cont)
+ (use-continuation cast cont)))
+ (t (use-continuation ref cont)))))
;;; Convert a reference to a symbolic constant or variable. If the
;;; symbol is entered in the LEXENV-VARS we use that definition,
(reference-leaf start cont var))
(cons
(aver (eq (car var) 'MACRO))
+ ;; FIXME: [Free] type declarations. -- APD, 2002-01-26
(ir1-convert start cont (cdr var)))
(heap-alien-info
(ir1-convert start cont `(%heap-alien ',var)))))
ir1-convert-combination))
(defun ir1-convert-combination (start cont form fun)
(let ((fun-cont (make-continuation)))
- (reference-leaf start fun-cont fun)
+ (ir1-convert start fun-cont `(the (or function symbol) ,fun))
(ir1-convert-combination-args fun-cont cont (cdr form))))
;;; Convert the arguments to a call and make the COMBINATION
(declare (type continuation fun-cont cont) (list args))
(let ((node (make-combination fun-cont)))
(setf (continuation-dest fun-cont) node)
- (assert-continuation-type fun-cont
- (specifier-type '(or function symbol))
- (lexenv-policy *lexenv*))
- (setf (continuation-%externally-checkable-type fun-cont) nil)
(collect ((arg-conts))
(let ((this-start fun-cont))
(dolist (arg args)
(fun-cont (basic-combination-fun node))
(type (leaf-type var)))
(when (validate-call-type node type t)
- (setf (continuation-%derived-type fun-cont) type)
- (setf (continuation-reoptimize fun-cont) nil)
- (setf (continuation-%type-check fun-cont) nil)))
+ (setf (continuation-%derived-type fun-cont)
+ (make-single-value-type type))
+ (setf (continuation-reoptimize fun-cont) nil)))
(values))
;;; Convert a call to a local function, or if the function has already
;;; declarations that constrain the type of lexically apparent
;;; functions.
(defun process-ftype-decl (spec res names fvars)
- (declare (type type-specifier spec)
- (type list names fvars)
+ (declare (type list names fvars)
(type lexenv res))
(let ((type (compiler-specifier-type spec)))
(collect ((res nil cons))
:policy (process-optimize-decl spec (lexenv-policy res))))
(type
(process-type-decl (cdr spec) res vars))
- (values
- (if *suppress-values-declaration*
+ (values ;; FIXME -- APD, 2002-01-26
+ (if t ; *suppress-values-declaration*
res
(let ((types (cdr spec)))
(ir1ize-the-or-values (if (eql (length types) 1)
(compiler-error
"The list ~S is too long to be an arg specifier."
spec)))))))
-
+
(dolist (name required)
(let ((var (varify-lambda-arg name (names-so-far))))
(vars var)
(names-so-far name)))
-
+
(dolist (spec optional)
(if (atom spec)
(let ((var (varify-lambda-arg spec (names-so-far))))
(vars var)
(names-so-far name)
(parse-default spec info))))
-
+
(when restp
(let ((var (varify-lambda-arg rest (names-so-far))))
(setf (lambda-var-arg-info var) (make-arg-info :kind :rest))
(make-arg-info :kind :more-count))
(vars var)
(names-so-far more-count)))
-
+
(dolist (spec keys)
(cond
((atom spec)
(vars var)
(names-so-far name)
(parse-default spec info))))))
-
+
(dolist (spec aux)
(cond ((atom spec)
(let ((var (varify-lambda-arg spec nil)))
(ir1-convert-progn-body start cont body)
(let ((fun-cont (make-continuation))
(fun (ir1-convert-lambda-body body
- (list (first aux-vars))
- :aux-vars (rest aux-vars)
- :aux-vals (rest aux-vals)
- :debug-name (debug-namify
- "&AUX bindings ~S"
- aux-vars))))
+ (list (first aux-vars))
+ :aux-vars (rest aux-vars)
+ :aux-vals (rest aux-vals)
+ :debug-name (debug-namify
+ "&AUX bindings ~S"
+ aux-vars))))
(reference-leaf start fun-cont fun)
(ir1-convert-combination-args fun-cont cont
(list (first aux-vals)))))
:%debug-name debug-name))
(result (or result (make-continuation))))
+ (continuation-starts-block result)
+
;; just to check: This function should fail internal assertions if
;; we didn't set up a valid debug name above.
;;
(setf (lambda-tail-set lambda) tail-set)
(setf (lambda-return lambda) return)
(setf (continuation-dest result) return)
- (setf (continuation-%externally-checkable-type result) nil)
+ (flush-continuation-externally-checkable-type result)
(setf (block-last block) return)
(link-node-to-previous-continuation return result)
(use-continuation return dummy))
(defun %compiler-defun (name lambda-with-lexenv)
(let ((defined-fun nil)) ; will be set below if we're in the compiler
-
+
(when (boundp '*lexenv*) ; when in the compiler
(when sb!xc:*compile-print*
(compiler-mumble "~&; recognizing DEFUN ~S~%" name))
(cond (lambda-with-lexenv
(setf (info :function :inline-expansion-designator name)
lambda-with-lexenv)
- (when defined-fun
+ (when defined-fun
(setf (defined-fun-inline-expansion defined-fun)
lambda-with-lexenv)))
(t
(:unused nil)
(:deleted nil)))
+(defun principal-continuation-use (cont)
+ (let ((use (continuation-use cont)))
+ (if (cast-p use)
+ (principal-continuation-use (cast-value use))
+ use)))
+
;;; Update continuation use information so that NODE is no longer a
;;; use of its CONT. If the old continuation doesn't start its block,
;;; then we don't update the BLOCK-START-USES, since it will be
(let ((uses (cons node (block-start-uses block))))
(setf (block-start-uses block) uses)
(setf (continuation-use cont)
- (if (cdr uses) nil (car uses)))))))
+ (if (cdr uses) nil (car uses)))
+ (let ((block (node-block node)))
+ (unless (block-last block)
+ (setf (block-last block) node)))))))
(setf (node-cont node) cont)
(values))
(declare (type continuation cont) (type node node))
(and (eq (node-cont node) cont)
(not (eq (continuation-kind cont) :deleted))
+ (eq (continuation-dest cont)
+ (continuation-next cont))
(let ((cblock (continuation-block cont))
(nblock (node-block node)))
(or (eq cblock nblock)
(if (eq old (basic-combination-fun dest))
(setf (basic-combination-fun dest) new)
(setf (basic-combination-args dest)
- (nsubst new old (basic-combination-args dest))))))
+ (nsubst new old (basic-combination-args dest)))))
+ (cast (setf (cast-value dest) new))
+ (null))
- (flush-dest old)
+ (when dest (flush-dest old))
(setf (continuation-dest new) dest)
- (setf (continuation-%externally-checkable-type new) nil))
+ (flush-continuation-externally-checkable-type new))
(values))
;;; Replace all uses of OLD with uses of NEW, where NEW has an
(do-uses (node old)
(delete-continuation-use node)
(add-continuation-use node new))
- (dolist (lexenv-use (continuation-lexenv-uses old))
+ (dolist (lexenv-use (continuation-lexenv-uses old)) ; FIXME - APD
(setf (cadr lexenv-use) new))
(reoptimize-continuation new)
(node-ends-block (continuation-use cont))))))))
(values))
\f
+;;;;
+
+;;; Filter values of CONT with a destination through FORM, which must
+;;; be an ordinary/mv call. First argument must be 'DUMMY, which will
+;;; be replaced with CONT. In case of an ordinary call the function
+;;; should not have return type NIL.
+;;;
+;;; TODO: remove preconditions.
+(defun filter-continuation (cont form)
+ (declare (type continuation cont) (type list form))
+ (let ((dest (continuation-dest cont)))
+ (declare (type node dest))
+ (with-ir1-environment-from-node dest
+
+ ;; Ensuring that CONT starts a block lets us freely manipulate its uses.
+ (ensure-block-start cont)
+
+ ;; Make a new continuation and move CONT's uses to it.
+ (let ((new-start (make-continuation))
+ (prev (node-prev dest)))
+ (continuation-starts-block new-start)
+ (substitute-continuation-uses new-start cont)
+
+ ;; Make the DEST node start its block so that we can splice in
+ ;; the LAMBDA code.
+ (when (continuation-use prev)
+ (node-ends-block (continuation-use prev)))
+
+ (let* ((prev-block (continuation-block prev))
+ (new-block (continuation-block new-start))
+ (dummy (make-continuation)))
+
+ ;; Splice in the new block before DEST, giving the new block
+ ;; all of DEST's predecessors.
+ (dolist (block (block-pred prev-block))
+ (change-block-successor block prev-block new-block))
+
+ ;; Convert the lambda form, using the new block start as
+ ;; START and a dummy continuation as CONT.
+ (ir1-convert new-start dummy form)
+
+ ;; TODO: Why should this be true? -- WHN 19990601
+ ;;
+ ;; It is somehow related to the precondition of non-NIL
+ ;; return type of the function. -- APD 2003-3-24
+ (aver (eq (continuation-block dummy) new-block))
+
+ ;; KLUDGE: Comments at the head of this function in CMU CL
+ ;; said that somewhere in here we
+ ;; Set the new block's start and end cleanups to the *start*
+ ;; cleanup of PREV's block. This overrides the incorrect
+ ;; default from WITH-IR1-ENVIRONMENT-FROM-NODE.
+ ;; Unfortunately I can't find any code which corresponds to this.
+ ;; Perhaps it was a stale comment? Or perhaps I just don't
+ ;; understand.. -- WHN 19990521
+
+ (let ((node (continuation-use dummy)))
+ (setf (block-last new-block) node)
+ ;; Change the use to a use of CONT. (We need to use the
+ ;; dummy continuation to get the control transfer right,
+ ;; because we want to go to PREV's block, not CONT's.)
+ (delete-continuation-use node)
+ (add-continuation-use node cont))
+ ;; Link the new block to PREV's block.
+ (link-blocks new-block prev-block))
+
+ ;; Replace 'DUMMY with the new continuation. (We can find
+ ;; 'DUMMY because no LET conversion has been done yet.) The
+ ;; [mv-]combination code from the call in the form will be the
+ ;; use of the new check continuation. We substitute for the
+ ;; first argument of this node.
+ (let* ((node (continuation-use cont))
+ (args (basic-combination-args node))
+ (victim (first args)))
+ (aver (eq (constant-value (ref-leaf (continuation-use victim)))
+ 'dummy))
+ (substitute-continuation new-start victim)))
+
+ ;; Invoking local call analysis converts this call to a LET.
+ (locall-analyze-component *current-component*)
+
+ (values))))
+
+;;; Deleting a filter may result in some calls becoming tail.
+(defun delete-filter (node cont value)
+ (collect ((merges))
+ (prog2
+ (when (return-p (continuation-dest cont))
+ (do-uses (use value)
+ (when (and (basic-combination-p use)
+ (eq (basic-combination-kind use) :local))
+ (merges use))))
+ (cond ((and (eq (continuation-kind cont) :inside-block)
+ (eq (continuation-kind value) :inside-block))
+ (setf (continuation-dest value) nil)
+ (substitute-continuation value cont)
+ (prog1 (unlink-node node)
+ (setq cont value)))
+ (t (ensure-block-start value)
+ (ensure-block-start cont)
+ (substitute-continuation-uses cont value)
+ (prog1 (unlink-node node)
+ (setf (continuation-dest value) nil))))
+ (dolist (merge (merges))
+ (merge-tail-sets merge)))))
+\f
;;;; miscellaneous shorthand functions
;;; Return the home (i.e. enclosing non-LET) CLAMBDA for NODE. Since
;;; (BLOCK B (RETURN-FROM B) (SETQ X 3))
;;; where the block is just a placeholder during parsing and doesn't
;;; actually correspond to code which will be written anywhere.
+(declaim (ftype (sfunction (cblock) (or clambda null)) block-home-lambda-or-null))
(defun block-home-lambda-or-null (block)
- (declare (type cblock block))
(if (node-p (block-last block))
;; This is the old CMU CL way of doing it.
(node-home-lambda (block-last block))
(values nil nil))))
;;; Return the LAMBDA that is CONT's home, or NIL if there is none.
+(declaim (ftype (sfunction (continuation) (or clambda null))
+ continuation-home-lambda-or-null))
(defun continuation-home-lambda-or-null (cont)
;; KLUDGE: This function is a post-CMU-CL hack by WHN, and this
;; implementation might not be quite right, or might be uglier than
#!-sb-fluid (declaim (inline continuation-single-value-p))
(defun continuation-single-value-p (cont)
- (not (typep (continuation-dest cont)
- '(or creturn exit mv-combination))))
+ (let ((dest (continuation-dest cont)))
+ (typecase dest
+ ((or creturn exit cast)
+ nil)
+ (mv-combination
+ (eq (basic-combination-fun dest) cont))
+ (t
+ t))))
+
+(defun principal-continuation-end (cont)
+ (loop for prev = cont then (node-cont dest)
+ for dest = (continuation-dest prev)
+ while (cast-p dest)
+ finally (return (values dest prev))))
\f
;;; Return a new LEXENV just like DEFAULT except for the specified
;;; slot values. Values for the alist slots are NCONCed to the
(let ((new-pred (delq block1 (block-pred block2))))
(setf (block-pred block2) new-pred)
- (when (and new-pred (null (rest new-pred)))
+ (when (singleton-p new-pred)
(let ((pred-block (first new-pred)))
(when (if-p (block-last pred-block))
(setf (block-test-modified pred-block) t)))))
(values))
-;;; Note that something interesting has happened to VAR.
+;;; Note that something interesting has happened to VAR.
(defun reoptimize-lambda-var (var)
(declare (type lambda-var var))
(let ((fun (lambda-var-home var)))
(maybe-convert-to-assignment fun)))
(t
(maybe-convert-to-assignment fun)))))))
-
+
(dolist (ep (optional-dispatch-entry-points leaf))
(frob ep))
(when (optional-dispatch-more-entry leaf)
(unless (eq (continuation-kind cont) :deleted)
(aver (continuation-dest cont))
(setf (continuation-dest cont) nil)
- (setf (continuation-%externally-checkable-type cont) nil)
+ (flush-continuation-externally-checkable-type cont)
(do-uses (use cont)
(let ((prev (node-prev use)))
(unless (eq (continuation-kind prev) :deleted)
(setf (block-attributep (block-flags block) flush-p type-asserted)
t))))))
- (setf (continuation-%type-check cont) nil)
-
(values))
+(defun delete-dest (cont)
+ (let ((dest (continuation-dest cont)))
+ (when dest
+ (let ((prev (node-prev dest)))
+ (when (and prev
+ (not (eq (continuation-kind prev) :deleted)))
+ (let ((block (continuation-block prev)))
+ (unless (block-delete-p block)
+ (mark-for-deletion block))))))))
+
;;; Do a graph walk backward from BLOCK, marking all predecessor
;;; blocks with the DELETE-P flag.
(defun mark-for-deletion (block)
(setf (block-attributep (block-flags block) flush-p type-asserted) t)
(setf (component-reoptimize (block-component block)) t)))))
- (let ((dest (continuation-dest cont)))
- (when dest
- (let ((prev (node-prev dest)))
- (when (and prev
- (not (eq (continuation-kind prev) :deleted)))
- (let ((block (continuation-block prev)))
- (unless (block-delete-p block)
- (mark-for-deletion block)))))))
+ (delete-dest cont)
(setf (continuation-kind cont) :deleted)
(setf (continuation-dest cont) nil)
- (setf (continuation-%externally-checkable-type cont) nil)
+ (flush-continuation-externally-checkable-type cont)
(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 (continuation-%type-check cont) nil)
(setf (continuation-info cont) nil)
(values))
;;; whose values are received by nodes in the block.
(defun delete-block (block)
(declare (type cblock block))
- (aver (block-component block)) ; else block is already deleted!
+ (aver (block-component block)) ; else block is already deleted!
(note-block-deletion block)
(setf (block-delete-p block) t)
(flush-dest (set-value node))
(let ((var (set-var node)))
(setf (basic-var-sets var)
- (delete node (basic-var-sets var))))))
+ (delete node (basic-var-sets var)))))
+ (cast
+ (flush-dest (cast-value node))))
(delete-continuation (node-prev node)))
(tail-set (lambda-tail-set fun)))
(aver (lambda-return fun))
(setf (lambda-return fun) nil)
- (when (and tail-set (not (find-if #'lambda-return (tail-set-funs tail-set))))
+ (when (and tail-set (not (find-if #'lambda-return
+ (tail-set-funs tail-set))))
(setf (tail-set-type tail-set) *empty-type*)))
(values))
(aver (eq node last))
(let* ((succ (block-succ block))
(next (first succ)))
- (aver (and succ (null (cdr succ))))
+ (aver (singleton-p succ))
(cond
((member block succ)
(with-ir1-environment-from-node node
(after-args (subseq outside-args (1+ arg-position))))
(dolist (arg inside-args)
(setf (continuation-dest arg) outside)
- (setf (continuation-%externally-checkable-type arg) nil))
+ (flush-continuation-externally-checkable-type arg))
(setf (combination-args inside) nil)
(setf (combination-args outside)
(append before-args inside-args after-args))
(info :function :info 'list))
(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))))))
(defun flush-combination (combination)
(delete-ref ref)
(setf (ref-leaf ref) leaf)
(setf (leaf-ever-used leaf) t)
- (let ((ltype (leaf-type leaf)))
+ (let* ((ltype (leaf-type leaf))
+ (vltype (make-single-value-type ltype)))
(if (let* ((cont (node-cont ref))
(dest (continuation-dest cont)))
(and (basic-combination-p dest)
- (eq cont (basic-combination-fun dest))))
- (setf (node-derived-type ref) ltype)
- (derive-node-type ref ltype)))
+ (eq cont (basic-combination-fun dest))
+ (csubtypep ltype (specifier-type 'function))))
+ (setf (node-derived-type ref) vltype)
+ (derive-node-type ref vltype)))
(reoptimize-continuation (node-cont ref)))
(values))
(let ((action (event-info-action info)))
(when action (funcall action node))))
+
+;;;
+(defun make-cast (value type policy)
+ (declare (type continuation value)
+ (type ctype type)
+ (type policy policy))
+ (%make-cast :asserted-type type
+ :type-to-check (maybe-weaken-check type policy)
+ :value value
+ :derived-type (coerce-to-values type)))
+
+(defun cast-type-check (cast)
+ (declare (type cast cast))
+ (when (cast-reoptimize cast)
+ (ir1-optimize-cast cast t))
+ (cast-%type-check cast))
+
+(defun note-single-valuified-continuation (cont)
+ (declare (type continuation cont))
+ (let ((use (continuation-use cont)))
+ (cond ((ref-p use)
+ (let ((leaf (ref-leaf use)))
+ (when (and (lambda-var-p leaf)
+ (null (rest (leaf-refs leaf))))
+ (reoptimize-lambda-var leaf))))
+ ((or (null use) (combination-p use))
+ (dolist (node (find-uses cont))
+ (setf (node-reoptimize node) t)
+ (setf (block-reoptimize (node-block node)) t)
+ (setf (component-reoptimize (node-component node)) t))))))
(emit-move ref ir2-block entry res))))
(values))
-;;; Convert a SET node. If the node's CONT is annotated, then we also
+;;; Convert a SET node. If the NODE's CONT is annotated, then we also
;;; deliver the value to that continuation. If the var is a lexical
;;; variable with no refs, then we don't actually set anything, since
;;; the variable has been deleted.
(first (ir2-continuation-locs 2cont)))))
(ptype (ir2-continuation-primitive-type 2cont)))
- (cond ((and (eq (continuation-type-check cont) t)
- (multiple-value-bind (check types)
- (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
- ;; flushed.
- (unless (values-subtypep (continuation-proven-type cont)
- (first types))
- (let ((temp (make-normal-tn ptype)))
- (emit-type-check node block cont-tn temp
- (first types))
- temp)))))
- ((eq (tn-primitive-type cont-tn) ptype) cont-tn)
+ (cond ((eq (tn-primitive-type cont-tn) ptype) cont-tn)
(t
(let ((temp (make-normal-tn ptype)))
(emit-move node block cont-tn temp)
(let* ((locs (ir2-continuation-locs (continuation-info cont)))
(nlocs (length locs)))
(aver (= nlocs (length ptypes)))
- (if (eq (continuation-type-check cont) t)
- (multiple-value-bind (check types) (continuation-check-types cont nil)
- (aver (eq check :simple))
- (let ((ntypes (length types)))
- (mapcar (lambda (from to-type assertion)
- (let ((temp (make-normal-tn to-type)))
- (if assertion
- (emit-type-check node block from temp assertion)
- (emit-move node block from temp))
- temp))
- locs ptypes
- (if (< ntypes nlocs)
- (append types (make-list (- nlocs ntypes)
- :initial-element nil))
- types))))
- (mapcar (lambda (from to-type)
- (if (eq (tn-primitive-type from) to-type)
- from
- (let ((temp (make-normal-tn to-type)))
- (emit-move node block from temp)
- temp)))
- locs
- ptypes))))
+
+ (mapcar (lambda (from to-type)
+ (if (eq (tn-primitive-type from) to-type)
+ from
+ (let ((temp (make-normal-tn to-type)))
+ (emit-move node block from temp)
+ temp)))
+ locs
+ ptypes)))
\f
;;;; utilities for delivering values to continuations
dest))
(values))
+;;; Move each SRC TN into the corresponding DEST TN, checking types
+;;; and defaulting any unsupplied source values to NIL
+(defun move-results-checked (node block src dest types)
+ (declare (type node node) (type ir2-block block) (list src dest types))
+ (let ((nsrc (length src))
+ (ndest (length dest))
+ (ntypes (length types)))
+ (mapc (lambda (from to type)
+ (if type
+ (emit-type-check node block from to type)
+ (emit-move node block from to)))
+ (if (> ndest nsrc)
+ (append src (make-list (- ndest nsrc)
+ :initial-element (emit-constant nil)))
+ src)
+ dest
+ (if (> ndest ntypes)
+ (append types (make-list (- ndest ntypes)))
+ types)))
+ (values))
+
;;; If necessary, emit coercion code needed to deliver the RESULTS to
;;; the specified continuation. NODE and BLOCK provide context for
;;; emitting code. Although usually obtained from STANDARD-RESULT-TNs
((reference-tn-list (ir2-continuation-locs 2cont) t))
nvals))))))
(values))
+
+;;; CAST
+(defun ir2-convert-cast (node block)
+ (declare (type cast node)
+ (type ir2-block block))
+ (let* ((cont (node-cont node))
+ (2cont (continuation-info cont))
+ (value (cast-value node))
+ (2value (continuation-info value)))
+ (cond ((not 2cont))
+ ((eq (ir2-continuation-kind 2cont) :unused))
+ ((eq (ir2-continuation-kind 2cont) :unknown)
+ (aver (eq (ir2-continuation-kind 2value) :unknown))
+ (aver (not (cast-type-check node)))
+ (move-results-coerced node block
+ (ir2-continuation-locs 2value)
+ (ir2-continuation-locs 2cont)))
+ ((eq (ir2-continuation-kind 2cont) :fixed)
+ (aver (eq (ir2-continuation-kind 2value) :fixed))
+ (if (cast-type-check node)
+ (move-results-checked node block
+ (ir2-continuation-locs 2value)
+ (ir2-continuation-locs 2cont)
+ (multiple-value-bind (check types)
+ (cast-check-types node nil)
+ (aver (eq check :simple))
+ types))
+ (move-results-coerced node block
+ (ir2-continuation-locs 2value)
+ (ir2-continuation-locs 2cont))))
+ (t (bug "CAST cannot be :DELAYED.")))))
\f
;;;; template conversion
(declare (type combination call) (type continuation cont)
(type template template) (list rtypes))
(let* ((dtype (node-derived-type call))
- (type (if (and (or (eq (template-ltn-policy template) :safe)
- (policy call (= safety 0)))
- (continuation-type-check cont))
- (values-type-intersection
- dtype
- (continuation-asserted-type cont))
- dtype))
+ (type dtype)
(types (mapcar #'primitive-type
(if (values-type-p type)
(append (values-type-required type)
(values (make-load-time-constant-tn :fdefinition name) t))
(let* ((locs (ir2-continuation-locs 2cont))
(loc (first locs))
- (check (continuation-type-check cont))
(function-ptype (primitive-type-or-lose 'function)))
(aver (and (eq (ir2-continuation-kind 2cont) :fixed)
(= (length locs) 1)))
- (cond ((eq (tn-primitive-type loc) function-ptype)
- (aver (not (eq check t)))
- (values loc nil))
- (t
- (let ((temp (make-normal-tn function-ptype)))
- (aver (and (eq (ir2-continuation-primitive-type 2cont)
- function-ptype)
- (eq check t)))
- (emit-type-check node block loc temp
- (specifier-type 'function))
- (values temp nil))))))))
+ (aver (eq (tn-primitive-type loc) function-ptype))
+ (values loc nil)))))
;;; Set up the args to NODE in the current frame, and return a TN-REF
;;; list for the passing locations.
(last (block-last block))
(succ (block-succ block)))
(unless (if-p last)
- (aver (and succ (null (rest succ))))
+ (aver (singleton-p succ))
(let ((target (first succ)))
(cond ((eq target (component-tail (block-component block)))
(when (and (basic-combination-p last)
(ir2-convert-return node 2block))
(cset
(ir2-convert-set node 2block))
+ (cast
+ (ir2-convert-cast node 2block))
(mv-combination
(cond
((eq (basic-combination-kind node) :local)
;;;
;;; If there is a &MORE arg, then there are a couple of optimizations
;;; that we make (more for space than anything else):
-;;; -- If MIN-ARGS is 0, then we make the more entry a T clause, since
+;;; -- If MIN-ARGS is 0, then we make the more entry a T clause, since
;;; no argument count error is possible.
-;;; -- We can omit the = clause for the last entry-point, allowing the
+;;; -- We can omit the = clause for the last entry-point, allowing the
;;; case of 0 more args to fall through to the more entry.
;;;
;;; We don't bother to policy conditionalize wrong arg errors in
(assert-continuation-type
(first (basic-combination-args call))
- (make-values-type :optional (mapcar #'leaf-type (lambda-vars ep))
- :rest *universal-type*)
+ (make-short-values-type (mapcar #'leaf-type (lambda-vars ep)))
(lexenv-policy (node-lexenv call)))))
(values))
(join-components component clambda-component)))
(let ((*current-component* component))
(node-ends-block call))
- ;; FIXME: Use DESTRUCTURING-BIND here, and grep for other
+ ;; FIXME: Use DESTRUCTURING-BIND here, and grep for other
;; uses of '=.*length' which could also be converted to use
;; DESTRUCTURING-BIND or PROPER-LIST-OF-LENGTH-P.
(aver (= (length (block-succ call-block)) 1))
;;; node, and change the control flow to transfer to NEXT-BLOCK
;;; instead. Move all the uses of the result continuation to CALL's
;;; CONT.
-;;;
-;;; If the actual continuation is only used by the LET call, then we
-;;; intersect the type assertion on the dummy continuation with the
-;;; assertion for the actual continuation; in all other cases
-;;; assertions on the dummy continuation are lost.
-;;;
-;;; We also intersect the derived type of the CALL with the derived
-;;; type of all the dummy continuation's uses. This serves mainly to
-;;; propagate TRULY-THE through LETs.
(defun move-return-uses (fun call next-block)
(declare (type clambda fun) (type basic-combination call)
(type cblock next-block))
(let ((result (return-result return))
(cont (node-cont call))
(call-type (node-derived-type call)))
- (when (eq (continuation-use cont) call)
- (set-continuation-type-assertion
- cont
- (continuation-asserted-type result)
- (continuation-type-to-check result)))
(unless (eq call-type *wild-type*)
- (do-uses (use result)
+ ;; FIXME: Replace the call with unsafe CAST. -- APD, 2002-01-26
+ (do-uses (use result)
(derive-node-type use call-type)))
(substitute-continuation-uses cont result)))
(values))
(delete-continuation-use call)
(add-continuation-use call (return-result call-return)))
(move-return-uses fun call
- (or next-block (node-block call-return)))))
+ (or next-block
+ (let ((block (node-block call-return)))
+ (when (block-delete-p block)
+ (setf (block-delete-p block) nil))
+ block)))))
(t
(aver (node-tail-p call))
(setf (lambda-return call-fun) return)
((:safe :fast-safe) t)
((:small :fast) nil)))
-;;; Called when an unsafe policy indicates that no type check should
-;;; be done on CONT. We delete the type check unless it is :ERROR
-;;; (indicating a compile-time type error.)
-(defun flush-type-check (cont)
- (declare (type continuation cont))
- (when (member (continuation-type-check cont) '(t :no-check))
- (setf (continuation-%type-check cont) :deleted))
- (values))
-
;;; an annotated continuation's primitive-type
#!-sb-fluid (declaim (inline continuation-ptype))
(defun continuation-ptype (cont)
;;; Annotate a normal single-value continuation. If its only use is a
;;; ref that we are allowed to delay the evaluation of, then we mark
;;; the continuation for delayed evaluation, otherwise we assign a TN
-;;; to hold the continuation's value. If the continuation has a type
-;;; check, we make the TN according to the proven type to ensure that
-;;; the possibly erroneous value can be represented.
+;;; to hold the continuation's value.
(defun annotate-1-value-continuation (cont)
(declare (type continuation cont))
(let ((info (continuation-info cont)))
(cond
((continuation-delayed-leaf cont)
(setf (ir2-continuation-kind info) :delayed))
- ((member (continuation-type-check cont) '(:deleted nil))
- (setf (ir2-continuation-locs info)
- (list (make-normal-tn (ir2-continuation-primitive-type info)))))
- (t
- (setf (ir2-continuation-locs info)
- (list (make-normal-tn
- (primitive-type
- (single-value-type (continuation-proven-type cont)))))))))
+ (t (setf (ir2-continuation-locs info)
+ (list (make-normal-tn (ir2-continuation-primitive-type info)))))))
+ (ltn-annotate-casts cont)
(values))
;;; Make an IR2-CONTINUATION corresponding to the continuation type
-;;; and then do ANNOTATE-1-VALUE-CONTINUATION. If POLICY-KEYWORD isn't
-;;; a safe policy keyword, then we clear the TYPE-CHECK flag.
-(defun annotate-ordinary-continuation (cont ltn-policy)
- (declare (type continuation cont)
- (type ltn-policy ltn-policy))
+;;; and then do ANNOTATE-1-VALUE-CONTINUATION.
+(defun annotate-ordinary-continuation (cont)
+ (declare (type continuation cont))
(let ((info (make-ir2-continuation
(primitive-type (continuation-type cont)))))
(setf (continuation-info cont) info)
- (unless (ltn-policy-safe-p ltn-policy)
- (flush-type-check cont))
(annotate-1-value-continuation cont))
(values))
;;; Annotate the function continuation for a full call. If the only
;;; reference is to a global function and DELAY is true, then we delay
;;; the reference, otherwise we annotate for a single value.
-;;;
-;;; Unlike for an argument, we only clear the type check flag when the
-;;; LTN-POLICY is unsafe, since the check for a valid function
-;;; object must be done before the call.
-(defun annotate-fun-continuation (cont ltn-policy &optional (delay t))
- (declare (type continuation cont) (type ltn-policy ltn-policy))
- (unless (ltn-policy-safe-p ltn-policy)
- (flush-type-check cont))
- (let* ((ptype (primitive-type (continuation-type cont)))
- (tn-ptype (if (member (continuation-type-check cont) '(:deleted nil))
- ptype
- (primitive-type
- (single-value-type
- (continuation-proven-type cont)))))
- (info (make-ir2-continuation ptype)))
+(defun annotate-fun-continuation (cont &optional (delay t))
+ (declare (type continuation cont))
+ (let* ((tn-ptype (primitive-type (continuation-type cont)))
+ (info (make-ir2-continuation tn-ptype)))
(setf (continuation-info cont) info)
(let ((name (continuation-fun-name cont t)))
(if (and delay name)
(setf (ir2-continuation-kind info) :delayed)
(setf (ir2-continuation-locs info)
(list (make-normal-tn tn-ptype))))))
+ (ltn-annotate-casts cont)
(values))
;;; If TAIL-P is true, then we check to see whether the call can really
(setf (node-tail-p call) nil)))))
(values))
-;;; We set the kind to :FULL or :FUNNY, depending on whether there is an
-;;; IR2-CONVERT method. If a funny function, then we inhibit tail recursion
-;;; and type check normally, since the IR2 convert method is going to want to
-;;; deliver values normally. We still annotate the function continuation,
-;;; since IR2tran might decide to call after all.
-;;;
-;;; If not funny, we flush arg type checks, when LTN-POLICY is not
-;;; safe.
+;;; We set the kind to :FULL or :FUNNY, depending on whether there is
+;;; an IR2-CONVERT method. If a funny function, then we inhibit tail
+;;; recursion normally, since the IR2 convert method is going to want
+;;; to deliver values normally. We still annotate the function
+;;; continuation, since IR2tran might decide to call after all.
;;;
-;;; Note that args may already be annotated because template selection can
-;;; bail out to here.
-(defun ltn-default-call (call ltn-policy)
- (declare (type combination call) (type ltn-policy ltn-policy))
+;;; Note that args may already be annotated because template selection
+;;; can bail out to here.
+(defun ltn-default-call (call)
+ (declare (type combination call))
(let ((kind (basic-combination-kind call)))
- (annotate-fun-continuation (basic-combination-fun call) ltn-policy)
+ (annotate-fun-continuation (basic-combination-fun call))
(cond
- ((and (fun-info-p kind)
- (fun-info-ir2-convert kind))
- (setf (basic-combination-info call) :funny)
- (setf (node-tail-p call) nil)
- (dolist (arg (basic-combination-args call))
- (unless (continuation-info arg)
- (setf (continuation-info arg)
- (make-ir2-continuation
- (primitive-type
- (continuation-type arg)))))
- (annotate-1-value-continuation arg)))
- (t
- (let ((safe-p (ltn-policy-safe-p ltn-policy)))
- (dolist (arg (basic-combination-args call))
- (unless safe-p (flush-type-check arg))
- (unless (continuation-info arg)
- (setf (continuation-info arg)
- (make-ir2-continuation
- (primitive-type
- (continuation-type arg)))))
- (annotate-1-value-continuation arg)))
- (when (eq kind :error)
- (setf (basic-combination-kind call) :full))
- (setf (basic-combination-info call) :full)
- (flush-full-call-tail-transfer call))))
+ ((and (fun-info-p kind)
+ (fun-info-ir2-convert kind))
+ (setf (basic-combination-info call) :funny)
+ (setf (node-tail-p call) nil)
+ (dolist (arg (basic-combination-args call))
+ (unless (continuation-info arg)
+ (setf (continuation-info arg)
+ (make-ir2-continuation
+ (primitive-type
+ (continuation-type arg)))))
+ (annotate-1-value-continuation arg)))
+ (t
+ (dolist (arg (basic-combination-args call))
+ (unless (continuation-info arg)
+ (setf (continuation-info arg)
+ (make-ir2-continuation
+ (primitive-type
+ (continuation-type arg)))))
+ (annotate-1-value-continuation arg))
+ (when (eq kind :error)
+ (setf (basic-combination-kind call) :full))
+ (setf (basic-combination-info call) :full)
+ (flush-full-call-tail-transfer call))))
(values))
;;; Annotate a continuation for unknown multiple values:
-;;; -- Delete any type check, regardless of LTN-POLICY, since IR2
-;;; conversion isn't prepared to check unknown-values continuations.
-;;; If we delete a type check when the policy is safe, then we emit
-;;; a warning.
;;; -- Add the continuation to the IR2-BLOCK-POPPED if it is used
;;; across a block boundary.
;;; -- Assign an :UNKNOWN IR2-CONTINUATION.
;;; of CONT's DEST, and called in the order that the continuations are
;;; received. Otherwise the IR2-BLOCK-POPPED and
;;; IR2-COMPONENT-VALUES-FOO would get all messed up.
-(defun annotate-unknown-values-continuation (cont ltn-policy)
- (declare (type continuation cont) (type ltn-policy ltn-policy))
- (when (eq (continuation-type-check cont) t)
- (let* ((dest (continuation-dest cont))
- (*compiler-error-context* dest))
- (when (and (ltn-policy-safe-p ltn-policy)
- (policy dest (>= safety inhibit-warnings)))
- (compiler-note "compiler limitation: ~
- unable to check type assertion in ~
- unknown-values context:~% ~S"
- (continuation-asserted-type cont))))
- (setf (continuation-%type-check cont) :deleted))
+(defun annotate-unknown-values-continuation (cont)
+ (declare (type continuation cont))
+
+ (let ((2cont (make-ir2-continuation nil)))
+ (setf (ir2-continuation-kind 2cont) :unknown)
+ (setf (ir2-continuation-locs 2cont) (make-unknown-values-locations))
+ (setf (continuation-info cont) 2cont))
+
+ ;; The CAST chain with corresponding continuations constitute the
+ ;; same "principal continuation", so we must preserve only inner
+ ;; annotation order and the order of the whole p.c. with other
+ ;; continiations. -- APD, 2002-02-27
+ (ltn-annotate-casts cont)
(let* ((block (node-block (continuation-dest cont)))
(use (continuation-use cont))
(setf (ir2-block-popped 2block)
(nconc (ir2-block-popped 2block) (list cont)))))
- (let ((2cont (make-ir2-continuation nil)))
- (setf (ir2-continuation-kind 2cont) :unknown)
- (setf (ir2-continuation-locs 2cont) (make-unknown-values-locations))
- (setf (continuation-info cont) 2cont))
-
(values))
;;; Annotate CONT for a fixed, but arbitrary number of values, of the
-;;; specified primitive TYPES. If the continuation has a type check,
-;;; we annotate for the number of values indicated by TYPES, but only
-;;; use proven type information.
-(defun annotate-fixed-values-continuation (cont ltn-policy types)
- (declare (type continuation cont) (type ltn-policy ltn-policy) (list types))
- (unless (ltn-policy-safe-p ltn-policy)
- (flush-type-check cont))
+;;; specified primitive TYPES.
+(defun annotate-fixed-values-continuation (cont types)
+ (declare (type continuation cont) (list types))
(let ((res (make-ir2-continuation nil)))
- (if (member (continuation-type-check cont) '(:deleted nil))
- (setf (ir2-continuation-locs res) (mapcar #'make-normal-tn types))
- (let* ((proven (mapcar (lambda (x)
- (make-normal-tn (primitive-type x)))
- (values-types
- (continuation-proven-type cont))))
- (num-proven (length proven))
- (num-types (length types)))
- (setf (ir2-continuation-locs res)
- (cond
- ((< num-proven num-types)
- (append proven
- (make-n-tns (- num-types num-proven)
- *backend-t-primitive-type*)))
- ((> num-proven num-types)
- (subseq proven 0 num-types))
- (t
- proven)))))
+ (setf (ir2-continuation-locs res) (mapcar #'make-normal-tn types))
(setf (continuation-info cont) res))
+ (ltn-annotate-casts cont)
(values))
\f
;;;; node-specific analysis functions
;;; perverse code, we may annotate for unknown values when we
;;; didn't have to.
;;; * Otherwise, we must annotate the continuation for unknown values.
-(defun ltn-analyze-return (node ltn-policy)
- (declare (type creturn node) (type ltn-policy ltn-policy))
+(defun ltn-analyze-return (node)
+ (declare (type creturn node))
(let* ((cont (return-result node))
(fun (return-lambda node))
(returns (tail-set-info (lambda-tail-set fun)))
(member (basic-combination-info use) '(:local :full)))
(res (node-derived-type use))))
- (let ((int (values-type-intersection
- (res)
- (continuation-asserted-type cont))))
+ (let ((int (res)))
(multiple-value-bind (types kind)
- (values-types (if (eq int *empty-type*) (res) int))
+ (if (eq int *empty-type*)
+ (values nil :unknown)
+ (values-types int))
(if (eq kind :unknown)
- (annotate-unknown-values-continuation cont ltn-policy)
+ (annotate-unknown-values-continuation cont)
(annotate-fixed-values-continuation
- cont ltn-policy (mapcar #'primitive-type types))))))
- (annotate-fixed-values-continuation cont ltn-policy types)))
+ cont (mapcar #'primitive-type types))))))
+ (annotate-fixed-values-continuation cont types)))
(values))
;;; continuation. We look at the called lambda to determine number and
;;; type of return values desired. It is assumed that only a function
;;; that LOOKS-LIKE-AN-MV-BIND will be converted to a local call.
-(defun ltn-analyze-mv-bind (call ltn-policy)
- (declare (type mv-combination call)
- (type ltn-policy ltn-policy))
+(defun ltn-analyze-mv-bind (call)
+ (declare (type mv-combination call))
(setf (basic-combination-kind call) :local)
(setf (node-tail-p call) nil)
(annotate-fixed-values-continuation
(first (basic-combination-args call))
- ltn-policy
(mapcar (lambda (var)
(primitive-type (basic-var-type var)))
(lambda-vars
;;; in IR1 as an MV call to the %THROW funny function. We annotate the
;;; tag continuation for a single value and the values continuation
;;; for unknown values.
-(defun ltn-analyze-mv-call (call ltn-policy)
- (declare (type mv-combination call) (type ltn-policy ltn-policy))
+(defun ltn-analyze-mv-call (call)
+ (declare (type mv-combination call))
(let ((fun (basic-combination-fun call))
(args (basic-combination-args call)))
(cond ((eq (continuation-fun-name fun) '%throw)
(setf (basic-combination-info call) :funny)
- (annotate-ordinary-continuation (first args) ltn-policy)
- (annotate-unknown-values-continuation (second args) ltn-policy)
+ (annotate-ordinary-continuation (first args))
+ (annotate-unknown-values-continuation (second args))
(setf (node-tail-p call) nil))
(t
(setf (basic-combination-info call) :full)
(annotate-fun-continuation (basic-combination-fun call)
- ltn-policy
nil)
(dolist (arg (reverse args))
- (annotate-unknown-values-continuation arg ltn-policy))
+ (annotate-unknown-values-continuation arg))
(flush-full-call-tail-transfer call))))
(values))
;;; Annotate the arguments as ordinary single-value continuations. And
;;; check the successor.
-(defun ltn-analyze-local-call (call ltn-policy)
- (declare (type combination call)
- (type ltn-policy ltn-policy))
+(defun ltn-analyze-local-call (call)
+ (declare (type combination call))
(setf (basic-combination-info call) :local)
(dolist (arg (basic-combination-args call))
(when arg
- (annotate-ordinary-continuation arg ltn-policy)))
+ (annotate-ordinary-continuation arg)))
(when (node-tail-p call)
(set-tail-local-call-successor call))
(values))
(values))
;;; Annotate the value continuation.
-(defun ltn-analyze-set (node ltn-policy)
- (declare (type cset node) (type ltn-policy ltn-policy))
+(defun ltn-analyze-set (node)
+ (declare (type cset node))
(setf (node-tail-p node) nil)
- (annotate-ordinary-continuation (set-value node) ltn-policy)
+ (annotate-ordinary-continuation (set-value node))
(values))
;;; If the only use of the TEST continuation is a combination
;;; a conditional template if the call immediately precedes the IF
;;; node in the same block, we know that any predicate will already be
;;; annotated.
-(defun ltn-analyze-if (node ltn-policy)
- (declare (type cif node) (type ltn-policy ltn-policy))
+(defun ltn-analyze-if (node)
+ (declare (type cif node))
(setf (node-tail-p node) nil)
(let* ((test (if-test node))
(use (continuation-use test)))
(let ((info (basic-combination-info use)))
(and (template-p info)
(eq (template-result-types info) :conditional))))
- (annotate-ordinary-continuation test ltn-policy)))
+ (annotate-ordinary-continuation test)))
(values))
;;; If there is a value continuation, then annotate it for unknown
;;; values. In this case, the exit is non-local, since all other exits
;;; are deleted or degenerate by this point.
-(defun ltn-analyze-exit (node ltn-policy)
+(defun ltn-analyze-exit (node)
(setf (node-tail-p node) nil)
(let ((value (exit-value node)))
(when value
- (annotate-unknown-values-continuation value ltn-policy)))
+ (annotate-unknown-values-continuation value)))
(values))
;;; We need a special method for %UNWIND-PROTECT that ignores the
(when (null args) (return nil))
(let ((arg (car args))
(type (car types)))
- (when (and (eq (continuation-type-check arg) :no-check)
- safe-p
- (not (eq (template-ltn-policy template) :safe)))
- (return nil))
(unless (operand-restriction-ok type (continuation-ptype arg)
:cont arg)
(return nil))))))
(declare (type template template) (type combination call))
(let* ((guard (template-guard template))
(cont (node-cont call))
- (atype (continuation-asserted-type cont))
(dtype (node-derived-type call)))
(cond ((and guard (not (funcall guard)))
(values nil :guard))
(immediately-used-p (if-test dest) call))
(values t nil)
(values nil :conditional))))
- ((template-results-ok
- template
- (if (and (or (eq (template-ltn-policy template) :safe)
- (not safe-p))
- (continuation-type-check cont))
- (values-type-intersection dtype atype)
- dtype))
+ ((template-results-ok template dtype)
(values t nil))
(t
(values nil :result-types)))))
(return))
(let* ((type (template-type loser))
(valid (valid-fun-use call type))
- (strict-valid (valid-fun-use call type
- :strict-result t)))
+ (strict-valid (valid-fun-use call type)))
(lose1 "unable to do ~A (cost ~W) because:"
(or (template-note loser) (template-name loser))
(template-cost loser))
. ,(messages))))))))
(values))
-;;; Flush type checks according to policy. If the policy is
-;;; unsafe, then we never do any checks. If our policy is safe, and
-;;; we are using a safe template, then we can also flush arg and
-;;; result type checks. Result type checks are only flushed when the
-;;; continuation has a single use. Result type checks are not flush if
-;;; the policy is safe because the selection of template for results
-;;; readers assumes the type check is done (uses the derived type
-;;; which is the intersection of the proven and asserted types).
-(defun flush-type-checks-according-to-ltn-policy (call ltn-policy template)
- (declare (type combination call) (type ltn-policy ltn-policy)
- (type template template))
- (let ((safe-op (eq (template-ltn-policy template) :safe)))
- (when (or (not (ltn-policy-safe-p ltn-policy)) safe-op)
- (dolist (arg (basic-combination-args call))
- (flush-type-check arg)))
- (when safe-op
- (let ((cont (node-cont call)))
- (when (and (eq (continuation-use cont) call)
- (not (ltn-policy-safe-p ltn-policy)))
- (flush-type-check cont)))))
-
- (values))
-
;;; If a function has a special-case annotation method use that,
;;; otherwise annotate the argument continuations and try to find a
;;; template corresponding to the type signature. If there is none,
;;; convert a full call.
-(defun ltn-analyze-known-call (call ltn-policy)
- (declare (type combination call)
- (type ltn-policy ltn-policy))
- (let ((method (fun-info-ltn-annotate (basic-combination-kind call)))
+(defun ltn-analyze-known-call (call)
+ (declare (type combination call))
+ (let ((ltn-policy (node-ltn-policy call))
+ (method (fun-info-ltn-annotate (basic-combination-kind call)))
(args (basic-combination-args call)))
(when method
(funcall method call ltn-policy)
(mapcar (lambda (arg)
(type-specifier (continuation-type arg)))
args))))
- (ltn-default-call call ltn-policy)
+ (ltn-default-call call)
(return-from ltn-analyze-known-call (values)))
(setf (basic-combination-info call) template)
(setf (node-tail-p call) nil)
- (flush-type-checks-according-to-ltn-policy call ltn-policy template)
-
(dolist (arg args)
(annotate-1-value-continuation arg))))
(values))
+
+;;; CASTs are merely continuation annotations than nodes. So we wait
+;;; until value consumer deside how values should be passed, and after
+;;; that we propagate this decision backwards through CAST chain. The
+;;; exception is a dangling CAST with a type check, which we process
+;;; immediately.
+(defun ltn-analyze-cast (cast)
+ (declare (type cast cast))
+ (setf (node-tail-p cast) nil)
+ (when (and (cast-type-check cast)
+ (not (continuation-dest (node-cont cast))))
+ ;; FIXME
+ (bug "IR2 type checking of unused values in not implemented.")
+ )
+ (values))
+
+(defun ltn-annotate-casts (cont)
+ (declare (type continuation cont))
+ (do-uses (node cont)
+ (when (cast-p node)
+ (ltn-annotate-cast node))))
+
+(defun ltn-annotate-cast (cast)
+ (declare (type cast))
+ (let ((2cont (continuation-info (node-cont cast)))
+ (value (cast-value cast)))
+ (aver 2cont)
+ ;; XXX
+ (ecase (ir2-continuation-kind 2cont)
+ (:unknown
+ (annotate-unknown-values-continuation value))
+ (:fixed
+ (let* ((count (length (ir2-continuation-locs 2cont)))
+ (ctype (continuation-derived-type value)))
+ (multiple-value-bind (types rest)
+ (values-type-types ctype (specifier-type 'null))
+ (annotate-fixed-values-continuation
+ value
+ (mapcar #'primitive-type
+ (adjust-list types count rest))))))))
+ (values))
+
\f
;;;; interfaces
(defun ltn-analyze-block (block)
(do* ((node (continuation-next (block-start block))
(continuation-next cont))
- (cont (node-cont node) (node-cont node))
- (ltn-policy (node-ltn-policy node) (node-ltn-policy node)))
+ (cont (node-cont node) (node-cont node)))
(nil)
+ (let ((dest (continuation-dest cont)))
+ (when (and (cast-p dest)
+ (not (cast-type-check dest))
+ (immediately-used-p cont node))
+ (derive-node-type node (cast-asserted-type dest))))
(etypecase node
(ref)
(combination
(case (basic-combination-kind node)
- (:local (ltn-analyze-local-call node ltn-policy))
- ((:full :error) (ltn-default-call node ltn-policy))
+ (:local (ltn-analyze-local-call node))
+ ((:full :error) (ltn-default-call node))
(t
- (ltn-analyze-known-call node ltn-policy))))
- (cif
- (ltn-analyze-if node ltn-policy))
- (creturn
- (ltn-analyze-return node ltn-policy))
+ (ltn-analyze-known-call node))))
+ (cif (ltn-analyze-if node))
+ (creturn (ltn-analyze-return node))
((or bind entry))
- (exit
- (ltn-analyze-exit node ltn-policy))
- (cset (ltn-analyze-set node ltn-policy))
+ (exit (ltn-analyze-exit node))
+ (cset (ltn-analyze-set node))
+ (cast (ltn-analyze-cast node))
(mv-combination
(ecase (basic-combination-kind node)
(:local
- (ltn-analyze-mv-bind node ltn-policy))
+ (ltn-analyze-mv-bind node))
((:full :error)
- (ltn-analyze-mv-call node ltn-policy)))))
+ (ltn-analyze-mv-call node)))))
(when (eq node (block-last block))
(return))))
(declare (type component component))
(let ((2comp (component-info component)))
(do-blocks (block component)
- ;; This assertion seems to protect us from compiling a component
- ;; twice. As noted above, "this is where we allocate IR2-BLOCKS
- ;; because it is the first place we need them", so if one is
- ;; already allocated here, something is wrong. -- WHN 2001-09-14
(aver (not (block-info block)))
(let ((2block (make-ir2-block block)))
(setf (block-info block) 2block)
- (ltn-analyze-block block)
+ (ltn-analyze-block block)))
+ (do-blocks (block component)
+ (let ((2block (block-info block)))
(let ((popped (ir2-block-popped 2block)))
(when popped
(push block (ir2-component-values-receivers 2comp)))))))
;;; If the desirability of the transformation depends on the current
;;; OPTIMIZE parameters, then the POLICY macro should be used to
;;; determine when to pass.
-(defmacro define-source-transform (name lambda-list &body body)
- (let ((fn-name
- (if (listp name)
- (collect ((pieces))
- (dolist (piece name)
- (pieces "-")
- (pieces piece))
- (apply #'symbolicate "SOURCE-TRANSFORM" (pieces)))
- (symbolicate "SOURCE-TRANSFORM-" name)))
- (n-form (gensym))
- (n-env (gensym)))
+(defmacro source-transform-lambda (lambda-list &body body)
+ (let ((n-form (gensym))
+ (n-env (gensym))
+ (name (gensym)))
(multiple-value-bind (body decls)
- (parse-defmacro lambda-list n-form body name "form"
+ (parse-defmacro lambda-list n-form body "source transform" "form"
:environment n-env
:error-fun `(lambda (&rest stuff)
(declare (ignore stuff))
- (return-from ,fn-name
+ (return-from ,name
(values nil t))))
- `(progn
- (defun ,fn-name (,n-form)
- (let ((,n-env *lexenv*))
- ,@decls
- ,body))
- (setf (info :function :source-transform ',name) #',fn-name)))))
+ `(lambda (,n-form &aux (,n-env *lexenv*))
+ ,@decls
+ (block ,name
+ ,body)))))
+(defmacro define-source-transform (name lambda-list &body body)
+ `(setf (info :function :source-transform ',name)
+ (source-transform-lambda ,lambda-list ,@body)))
\f
;;;; boolean attribute utilities
;;;;
;;;
;;; NAME-attributes attribute-name*
;;; Return a set of the named attributes.
-#+sb-xc-host
-(progn
+#-sb-xc
+(progn
(def!macro !def-boolean-attribute (name &rest attribute-names)
(let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*"))
;;; keywords specify the initial values for various optimizers that
;;; the function might have.
(defmacro defknown (name arg-types result-type &optional (attributes '(any))
- &rest keys)
+ &rest keys)
(when (and (intersection attributes '(any call unwind))
(intersection attributes '(movable)))
(error "function cannot have both good and bad attributes: ~S" attributes))
(when (member 'any attributes)
- (setf attributes (union '(call unsafe unwind) attributes)))
+ (setq attributes (union '(call unsafe unwind) attributes)))
(when (member 'flushable attributes)
(pushnew 'unsafely-flushable attributes))
(not (legal-fun-name-p name)))
name
(list name))
- '(function ,arg-types ,result-type)
+ '(sfunction ,arg-types ,result-type)
(ir1-attributes ,@attributes)
,@keys))
`(continuation-next ,cont-var)))
(,cont-var (node-cont ,node-var) (node-cont ,node-var)))
(())
+ (declare (type node ,node-var))
,@body
(when ,(if restart-p
`(eq ,node-var (block-last ,n-block))
(values (cdr ,n-res) t)
(values nil nil))))
-;;;
-(defmacro with-continuation-type-assertion ((cont ctype context) &body body)
- `(let ((*lexenv* (ir1ize-the-or-values ,ctype ,cont *lexenv* ,context)))
- ,@body))
-
(defmacro with-component-last-block ((component block) &body body)
(with-unique-names (old-last-block)
(once-only ((component component)
(input-pathname (verify-source-file input-file))
(source-info (make-file-source-info input-pathname))
(*compiler-trace-output* nil)) ; might be modified below
-
+
(unwind-protect
(progn
(when output-file
;; and will be null in a :INSIDE-BLOCK continuation when this is the
;; CONT of the LAST.
(next nil :type (or node null))
- ;; an assertion on the type of this continuation's value
- (asserted-type *wild-type* :type ctype)
;; cached type of this continuation's value. If NIL, then this must
;; be recomputed: see CONTINUATION-DERIVED-TYPE.
(%derived-type nil :type (or ctype null))
;; the optimizer for this node type doesn't care, it can elect not
;; to clear this flag.
(reoptimize t :type boolean)
- ;; an indication of what we have proven about how this contination's
- ;; type assertion is satisfied:
- ;;
- ;; NIL
- ;; No type check is necessary (proven type is a subtype of the assertion.)
- ;;
- ;; T
- ;; A type check is needed.
- ;;
- ;; :DELETED
- ;; Don't do a type check, but believe (intersect) the assertion.
- ;; A T check can be changed to :DELETED if we somehow prove the
- ;; check is unnecessary, or if we eliminate it through a policy
- ;; decision.
- ;;
- ;; :NO-CHECK
- ;; Type check generation sets the slot to this if a check is
- ;; called for, but it believes it has proven that the check won't
- ;; be done for policy reasons or because a safe implementation
- ;; will be used. In the latter case, LTN must ensure that a safe
- ;; implementation *is* used.
- ;;
- ;; 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))
(lexenv-uses nil :type list))
(def!method print-object ((x continuation) stream)
- (print-unreadable-object (x stream :type t :identity t)))
+ (print-unreadable-object (x stream :type t :identity t)
+ (format stream " #~D" (cont-num x))))
(defstruct (node (:constructor nil)
(:copier nil))
;; unique ID for debugging
#!+sb-show (id (new-object-id) :read-only t)
- ;; the bottom-up derived type for this node. This does not take into
- ;; consideration output type assertions on this node (actually on its CONT).
+ ;; the bottom-up derived type for this node.
(derived-type *wild-type* :type ctype)
;; True if this node needs to be optimized. This is set to true
;; whenever something changes about the value of a continuation
;; indicates what we do controlwise after evaluating this node. This
;; may be null during IR1 conversion.
(cont nil :type (or continuation null))
- ;; the continuation that this node is the next of. This is null
+ ;; the continuation that this node is the NEXT of. This is null
;; during IR1 conversion when we haven't linked the node in yet or
;; in nodes that have been deleted from the IR1 by UNLINK-NODE.
(prev nil :type (or continuation null))
;; KIND was :TOPLEVEL. Now it must be set explicitly, both for
;; :TOPLEVEL functions and for any other kind of functions that we
;; want to dump or return from #'CL:COMPILE or whatever.
- (has-external-references-p nil)
+ (has-external-references-p nil)
;; In a normal function, this is the external entry point (XEP)
;; lambda for this function, if any. Each function that is used
;; other than in a local call has an XEP, and all of the
;; anonymous. In SBCL (as opposed to CMU CL) we make all
;; FUNCTIONALs have debug names. The CMU CL code didn't bother
;; in many FUNCTIONALs, especially those which were likely to be
- ;; optimized away before the user saw them. However, getting
+ ;; optimized away before the user saw them. However, getting
;; that right requires a global understanding of the code,
;; which seems bad, so we just require names for everything.
(leaf-source-name functional)))
;;; initially (and forever) NIL, since REFs don't receive any values
;;; and don't have any IR1 optimizer.
(defstruct (ref (:include node (reoptimize nil))
- (:constructor make-ref (derived-type leaf))
+ (:constructor make-ref
+ (leaf
+ &aux (leaf-type (leaf-type leaf))
+ (derived-type
+ (make-single-value-type leaf-type))))
(:copier nil))
;; The leaf referenced.
(leaf nil :type leaf))
alternative)
(defstruct (cset (:include node
- (derived-type *universal-type*))
+ (derived-type (make-single-value-type
+ *universal-type*)))
(:conc-name set-)
(:predicate set-p)
(:constructor make-set)
(defprinter (creturn :conc-name return- :identity t)
lambda
result-type)
+
+;;; The CAST node represents type assertions. The check for
+;;; TYPE-TO-CHECK is performed and then the VALUE is declared to be of
+;;; type ASSERTED-TYPE.
+(defstruct (cast (:include node)
+ (:constructor %make-cast))
+ (asserted-type (missing-arg) :type ctype)
+ (type-to-check (missing-arg) :type ctype)
+ ;; an indication of what we have proven about how this type
+ ;; assertion is satisfied:
+ ;;
+ ;; NIL
+ ;; No type check is necessary (VALUE type is a subtype of the TYPE-TO-CHECK.)
+ ;;
+ ;; T
+ ;; A type check is needed.
+ (%type-check t :type (member t nil))
+ ;; the continuations which is checked
+ (value (missing-arg) :type continuation))
+(defprinter (cast :identity t)
+ %type-check
+ value
+ asserted-type
+ type-to-check)
\f
;;;; non-local exit support
;;;;
(error "can't understand type ~S~%" element-type))))))
(cond ((array-type-p array-type)
(get-element-type array-type))
- ((union-type-p array-type)
+ ((union-type-p array-type)
(apply #'type-union
(mapcar #'get-element-type (union-type-types array-type))))
(t
(declare (optimize (safety 0)))
(and ,@(when low
(if (consp low)
- `((> (the ,base ,n-object) ,(car low)))
- `((>= (the ,base ,n-object) ,low))))
+ `((> (truly-the ,base ,n-object) ,(car low)))
+ `((>= (truly-the ,base ,n-object) ,low))))
,@(when high
(if (consp high)
- `((< (the ,base ,n-object) ,(car high)))
- `((<= (the ,base ,n-object) ,high))))))))
+ `((< (truly-the ,base ,n-object) ,(car high)))
+ `((<= (truly-the ,base ,n-object) ,high))))))))
;;; Do source transformation of a test of a known numeric type. We can
;;; assume that the type doesn't have a corresponding predicate, since
,(transform-numeric-bound-test n-object type base)))
(:complex
`(and (complexp ,n-object)
- ,(once-only ((n-real `(realpart (the complex ,n-object)))
- (n-imag `(imagpart (the complex ,n-object))))
+ ,(once-only ((n-real `(realpart (truly-the complex ,n-object)))
+ (n-imag `(imagpart (truly-the complex ,n-object))))
`(progn
,n-imag ; ignorable
(and (typep ,n-real ',base)
;; the arg/result type restrictions. We compute this from the
;; PRIMITIVE-TYPE restrictions to make life easier for IR1 phases
;; that need to anticipate LTN's template selection.
- (type (missing-arg) :type fun-type)
+ (type (missing-arg) :type ctype)
;; lists of restrictions on the argument and result types. A
;; restriction may take several forms:
;; -- The restriction * is no restriction at all.
(done (gen-label)))
(inst jmp-short variable-values)
- (inst mov start esp-tn)
- (inst push (first *register-arg-tns*))
+ (cond ((location= start (first *register-arg-tns*))
+ (inst push (first *register-arg-tns*))
+ (inst lea start (make-ea :dword :base esp-tn :disp 4)))
+ (t (inst mov start esp-tn)
+ (inst push (first *register-arg-tns*))))
(inst mov count (fixnumize 1))
(inst jmp done)
;;; bug 194, fixed in part by APD "more strict type checking" patch
;;; (sbcl-devel 2002-08-07)
(progn
- #+nil ; FIXME: still broken in 0.7.7.19 (after patch)
(multiple-value-bind (result error)
(ignore-errors (multiple-value-prog1 (progn (the real '(1 2 3)))))
(assert (null result))
(assert (typep error 'type-error)))
- #+nil ; FIXME: still broken in 0.7.7.19 (after patch)
(multiple-value-bind (result error)
(ignore-errors (the real '(1 2 3)))
(assert (null result))
(assert (typep error 'type-error))))
+
+(defun bug194d ()
+ (null (ignore-errors
+ (let ((arg1 1)
+ (arg2 (identity (the real #(1 2 3)))))
+ (if (< arg1 arg2) arg1 arg2)))))
+(assert (eq (bug194d) t))
+
\f
;;; BUG 48a. and b. (symbol-macrolet handling), fixed by Eric Marsden
;;; and Raymond Toy for CMUCL, fix ported for sbcl-0.7.6.18.
*standard-input*)))
(assert failure-p)
(assert (raises-error? (funcall function) program-error)))
-#||
-BUG 48c, not yet fixed:
(multiple-value-bind (function warnings-p failure-p)
(compile nil '(lambda () (symbol-macrolet ((s nil)) (declare (special s)) s)))
(assert failure-p)
(assert (raises-error? (funcall function) program-error)))
-||#
\f
;;; bug 120a: Turned out to be constraining code looking like (if foo
;;; <X> <X>) where <X> was optimized by the compiler to be the exact
(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 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
;;; INLINE inside MACROLET
(declaim (inline to-be-inlined))
(when x
(assert (= (funcall (compile nil x) 1) 2))))
+;;;
+(defun bug192b (i)
+ (dotimes (j i)
+ (declare (type (mod 4) i))
+ (unless (< i 5)
+ (print j))))
+(assert (raises-error? (bug192b 6) type-error))
+
+(defun bug192c (x y)
+ (locally (declare (type fixnum x y))
+ (+ x (* 2 y))))
+(assert (raises-error? (bug192c 1.1 2) type-error))
+
+(assert (raises-error? (progn (the real (list 1)) t) type-error))
+
+(defun bug236 (a f)
+ (declare (optimize (speed 2) (safety 0)))
+ (+ 1d0
+ (the double-float
+ (multiple-value-prog1
+ (svref a 0)
+ (unless f (return-from bug236 0))))))
+(assert (eql (bug236 #(4) nil) 0))
+
;;; Bug reported by reported by rif on c.l.l 2003-03-05
(defun test-type-of-special-1 (x)
(declare (special x)
(n-i kids)))
;;; failed in 0.8alpha.0.4 with "The value 13 is not of type LIST."
(assert (= (baz8alpha04 12 13) 25))
+
+;;; evaluation order in structure slot writers
+(defstruct sswo
+ a b)
+(let* ((i 0)
+ (s (make-sswo :a (incf i) :b (incf i)))
+ (l (list s :v)))
+ (assert (= (sswo-a s) 1))
+ (assert (= (sswo-b s) 2))
+ (setf (sswo-a (pop l)) (pop l))
+ (assert (eq l nil))
+ (assert (eq (sswo-a s) :v)))
+
\f
;;;; tests not in the problem domain, but of the consistency of the
;;;; compiler machinery itself
(ignore-errors (ecase 1 (t 0) (1 2)))
(assert (eql result 2))
(assert (null error)))
-
+
;;; FTYPE should accept any functional type specifier
(compile nil '(lambda (x) (declare (ftype function f)) (f x)))
;;; Moellmann: CONVERT-MORE-CALL failed on the following call
(assert (eq (eval '((lambda (&key) 'u) :allow-other-keys nil)) 'u))
+(raises-error? (multiple-value-bind (a b c)
+ (eval '(truncate 3 4))
+ (declare (integer c))
+ (list a b c))
+ type-error)
+
+(assert (equal (multiple-value-list (the (values &rest integer)
+ (eval '(values 3))))
+ '(3)))
+
;;; Bug relating to confused representation for the wild function
;;; type:
(assert (null (funcall (eval '(lambda () (multiple-value-list (values)))))))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.0.2"
+"0.8.0.3"
projects / sbcl.git / commitdiff