From: Alexey Dejneka Date: Mon, 26 May 2003 04:25:52 +0000 (+0000) Subject: 0.8.0.3: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=05525d3a5906d7a89fcb689c26177732493c40ce;p=sbcl.git 0.8.0.3: 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. --- diff --git a/BUGS b/BUGS index d9e2e60..0715f86 100644 --- a/BUGS +++ b/BUGS @@ -84,7 +84,9 @@ WORKAROUND: 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))) @@ -877,65 +879,6 @@ WORKAROUND: 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) @@ -951,14 +894,6 @@ WORKAROUND: (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.) @@ -1183,23 +1118,6 @@ WORKAROUND: 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 @@ -1294,6 +1212,26 @@ WORKAROUND: (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. diff --git a/NEWS b/NEWS index f7482e6..c2928fa 100644 --- a/NEWS +++ b/NEWS @@ -1768,6 +1768,13 @@ changes in sbcl-0.8.0 relative to sbcl-0.8alpha.0 * 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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 424501d..1f7fc50 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -270,8 +270,9 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "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" @@ -733,12 +734,13 @@ retained, possibly temporariliy, because it might be used internally." ;; 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" @@ -768,6 +770,7 @@ retained, possibly temporariliy, because it might be used internally." "INDEX" "LOAD/STORE-INDEX" "SIGNED-BYTE-WITH-A-BITE-OUT" "UNSIGNED-BYTE-WITH-A-BITE-OUT" + "SFUNCTION" ;; ..and type predicates "INSTANCEP" "DOUBLE-FLOAT-P" @@ -855,6 +858,7 @@ retained, possibly temporariliy, because it might be used internally." "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" @@ -1027,7 +1031,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "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" @@ -1131,6 +1136,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "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" @@ -1255,6 +1262,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "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" @@ -1268,11 +1276,14 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "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" diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 2633215..d76500f 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -672,6 +672,15 @@ ;;;; 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 + "~@" + (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 diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 5619051..8b83b55 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -888,26 +888,29 @@ `(,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 @@ -968,15 +971,15 @@ (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) @@ -1002,25 +1005,18 @@ (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 "~@ old-length length) + (subseq list 0 length)) + (t list)))) ;;;; 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) @@ -892,6 +920,15 @@ which can be found at .~:@>" ;;;; 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) diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 5aace45..10ac973 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -68,14 +68,21 @@ (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 @@ -104,39 +111,67 @@ (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 diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index ae79940..26ebeb7 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -1060,7 +1060,7 @@ :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) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index ec42475..f7c6050 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -173,10 +173,7 @@ (!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)) @@ -322,7 +319,8 @@ (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)) @@ -332,23 +330,28 @@ ;;;; 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 @@ -370,31 +373,45 @@ ;;; 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 @@ -415,13 +432,47 @@ :initial-element rest2))) exact))) -;;; If TYPE isn't a values type, then make it into one: -;;; ==> (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: @@ -446,41 +497,31 @@ ;;; 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, @@ -493,27 +534,38 @@ :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 @@ -522,12 +574,12 @@ (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 @@ -536,39 +588,39 @@ :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)))))))))))) ;;;; type method interfaces @@ -582,9 +634,10 @@ (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 @@ -791,66 +844,40 @@ ;;;; 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 @@ -955,9 +982,7 @@ ;; 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*)) @@ -966,9 +991,6 @@ :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)) @@ -1019,7 +1041,7 @@ (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*))) @@ -1060,7 +1082,7 @@ (!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))) @@ -1152,7 +1174,7 @@ (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). @@ -1641,7 +1663,7 @@ (numeric-type-high type2) >= > t))) (t nil)))))) - + (!cold-init-forms (setf (info :type :kind 'number) @@ -2466,7 +2488,7 @@ (return nil))) (setf accumulator (type-intersection accumulator union)))))))) - + (!def-type-translator and (&whole whole &rest type-specifiers) (apply #'type-intersection (mapcar #'specifier-type diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 429d674..ec14add 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -285,8 +285,9 @@ ;; (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)) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index a90e96f..3e2c5ca 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -191,7 +191,10 @@ ;;; 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)) diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp index f583403..87f42d1 100644 --- a/src/code/target-signal.lisp +++ b/src/code/target-signal.lisp @@ -61,7 +61,7 @@ ;;;; 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 @@ -72,7 +72,7 @@ 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)) diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index b45d004..4a1f65f 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -148,6 +148,8 @@ ;;; 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* diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp index 6169ace..45b9104 100644 --- a/src/code/typedefs.lisp +++ b/src/code/typedefs.lisp @@ -76,7 +76,7 @@ (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 @@ -128,6 +128,15 @@ (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)) ;;;; cold loading initializations diff --git a/src/code/x86-vm.lisp b/src/code/x86-vm.lisp index 0b15e82..203b2bb 100644 --- a/src/code/x86-vm.lisp +++ b/src/code/x86-vm.lisp @@ -52,6 +52,13 @@ (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. ;;; @@ -69,8 +76,7 @@ (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))) @@ -80,7 +86,7 @@ (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))))))) @@ -133,8 +139,7 @@ (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))) @@ -144,7 +149,7 @@ (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))))))) diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp index 85f2b1a..f006f7d 100644 --- a/src/compiler/aliencomp.lisp +++ b/src/compiler/aliencomp.lisp @@ -647,9 +647,9 @@ ((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) diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 134e3b8..ec5e9aa 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -103,16 +103,15 @@ (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))))))) ;;;; checking strategy determination @@ -164,7 +163,7 @@ (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) @@ -219,58 +218,88 @@ ;;; 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 @@ -282,16 +311,13 @@ ;;; -- 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) @@ -319,149 +345,91 @@ (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, @@ -494,40 +462,33 @@ ;;; 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)) diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index 5e61624..17b51ee 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -279,7 +279,7 @@ (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.) @@ -378,13 +378,14 @@ (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)) @@ -429,10 +430,11 @@ (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) @@ -441,7 +443,7 @@ (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))))))))) diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index 288bad7..c6bee54 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -103,11 +103,10 @@ ;;; 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 @@ -116,68 +115,61 @@ (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 @@ -415,7 +407,7 @@ :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) @@ -564,7 +556,7 @@ 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. ;;; @@ -734,7 +726,8 @@ (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))) @@ -763,7 +756,7 @@ (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) @@ -786,3 +779,23 @@ 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))) diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index 5f2c6e1..b9b8cb3 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -528,6 +528,8 @@ (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 @@ -997,7 +999,13 @@ ((exit-entry node) (format t "exit ")) (t - (format t "exit ")))))) + (format t "exit "))))) + (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))))) diff --git a/src/compiler/dfo.lisp b/src/compiler/dfo.lisp index 291a1cb..c03fa36 100644 --- a/src/compiler/dfo.lisp +++ b/src/compiler/dfo.lisp @@ -32,7 +32,7 @@ (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)) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 113cb1d..4536f45 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1325,6 +1325,11 @@ (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 diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index 5228849..16f8a6b 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -96,6 +96,8 @@ (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) @@ -131,6 +133,8 @@ (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")) diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index 8d51a97..a5abe11 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -134,9 +134,17 @@ ;; (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 diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 892ddfc..ec67238 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -423,31 +423,29 @@ (reference-constant start cont thing)) ;;;; 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))) ;;;; FUNCALL @@ -464,11 +462,11 @@ ,@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 @@ -568,7 +566,7 @@ (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 @@ -677,97 +675,52 @@ ;;;; 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)) ;;;; SETQ @@ -799,6 +752,7 @@ (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 @@ -813,12 +767,10 @@ ;;; 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) @@ -1007,11 +959,7 @@ (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) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index d585c20..2e8c17f 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -22,39 +22,18 @@ ;;; 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)))) ;;;; 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 @@ -63,7 +42,7 @@ ;;; ;;; 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 @@ -76,46 +55,26 @@ (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))) @@ -154,8 +113,12 @@ 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)) ;;;; interface routines used by optimizers @@ -172,8 +135,8 @@ ;;; 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) @@ -190,6 +153,13 @@ (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 @@ -203,7 +173,8 @@ (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*) @@ -215,41 +186,37 @@ (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 @@ -311,21 +278,15 @@ (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))))) @@ -337,7 +298,7 @@ (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)))))) @@ -389,7 +350,9 @@ (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)) @@ -398,7 +361,7 @@ (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))) @@ -407,6 +370,7 @@ ;; The successor has more than one predecessor. (rest (block-pred next)) ;; The last node's CONT is also used somewhere else. + ;; (as in (IF (M-V-PROG1 ...) (M-V-PROG1 ...))) (not (eq (continuation-use last-cont) last)) ;; The successor is the current block (infinite loop). (eq next block) @@ -421,13 +385,13 @@ (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 @@ -444,6 +408,17 @@ (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)))))) @@ -505,20 +480,7 @@ ;; 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 @@ -542,7 +504,11 @@ (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)) @@ -578,9 +544,12 @@ (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)) @@ -636,25 +605,22 @@ (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 @@ -687,7 +653,7 @@ (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) @@ -729,22 +695,14 @@ (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))))) + ;;;; combination IR1 optimization @@ -800,13 +758,13 @@ (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))) @@ -819,54 +777,54 @@ (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 @@ -1015,24 +973,16 @@ 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)) ;;;; known function optimization @@ -1068,7 +1018,7 @@ (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 @@ -1294,7 +1244,12 @@ (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 @@ -1306,7 +1261,7 @@ (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)) @@ -1324,7 +1279,8 @@ (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 @@ -1351,12 +1307,10 @@ ;;; 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 @@ -1365,25 +1319,29 @@ (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) @@ -1412,9 +1370,9 @@ ;;; 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 @@ -1440,8 +1398,10 @@ (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 @@ -1454,11 +1414,11 @@ 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)) @@ -1574,9 +1534,9 @@ (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)) @@ -1614,7 +1574,7 @@ (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) @@ -1709,7 +1669,7 @@ (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))) @@ -1745,7 +1705,7 @@ (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)) @@ -1764,3 +1724,60 @@ (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))) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index c05b5d0..3d76cc5 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -215,7 +215,7 @@ ;;; 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) @@ -303,10 +303,6 @@ ;;; 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)) @@ -334,20 +330,7 @@ (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))) ;;;; exported functions @@ -477,8 +460,10 @@ (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 @@ -522,7 +507,7 @@ (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))) @@ -543,7 +528,7 @@ (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 @@ -557,23 +542,28 @@ ;;; 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, @@ -595,6 +585,7 @@ (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))))) @@ -748,7 +739,7 @@ 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 @@ -759,10 +750,6 @@ (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) @@ -831,9 +818,9 @@ (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 @@ -953,8 +940,7 @@ ;;; 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)) @@ -1120,8 +1106,8 @@ :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) @@ -1267,12 +1253,12 @@ (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)))) @@ -1287,7 +1273,7 @@ (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)) @@ -1305,7 +1291,7 @@ (make-arg-info :kind :more-count)) (vars var) (names-so-far more-count))) - + (dolist (spec keys) (cond ((atom spec) @@ -1342,7 +1328,7 @@ (vars var) (names-so-far name) (parse-default spec info)))))) - + (dolist (spec aux) (cond ((atom spec) (let ((var (varify-lambda-arg spec nil))) @@ -1375,12 +1361,12 @@ (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))))) @@ -1457,6 +1443,8 @@ :%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. ;; @@ -1505,7 +1493,7 @@ (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)) @@ -2169,7 +2157,7 @@ (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)) @@ -2181,7 +2169,7 @@ (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 diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index b3f02b5..9502ae7 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -63,6 +63,12 @@ (: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 @@ -114,7 +120,10 @@ (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)) @@ -124,6 +133,8 @@ (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) @@ -150,11 +161,13 @@ (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 @@ -170,7 +183,7 @@ (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) @@ -232,6 +245,112 @@ (node-ends-block (continuation-use cont)))))))) (values)) +;;;; + +;;; 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))))) + ;;;; miscellaneous shorthand functions ;;; Return the home (i.e. enclosing non-LET) CLAMBDA for NODE. Since @@ -280,8 +399,8 @@ ;;; (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)) @@ -363,6 +482,8 @@ (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 @@ -387,8 +508,20 @@ #!-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)))) ;;; Return a new LEXENV just like DEFAULT except for the specified ;;; slot values. Values for the alist slots are NCONCed to the @@ -477,7 +610,7 @@ (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))))) @@ -642,7 +775,7 @@ (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))) @@ -776,7 +909,7 @@ (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) @@ -839,7 +972,7 @@ (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) @@ -848,10 +981,18 @@ (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) @@ -890,26 +1031,16 @@ (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)) @@ -924,7 +1055,7 @@ ;;; 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) @@ -989,7 +1120,9 @@ (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))) @@ -1003,7 +1136,8 @@ (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)) @@ -1145,7 +1279,7 @@ (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 @@ -1236,7 +1370,7 @@ (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)) @@ -1246,8 +1380,6 @@ (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) @@ -1269,13 +1401,15 @@ (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)) @@ -1546,3 +1680,33 @@ (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)))))) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 5994239..b564389 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -233,7 +233,7 @@ (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. @@ -289,20 +289,7 @@ (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) @@ -322,29 +309,15 @@ (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))) ;;;; utilities for delivering values to continuations @@ -438,6 +411,27 @@ 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 @@ -467,6 +461,37 @@ ((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."))))) ;;;; template conversion @@ -537,13 +562,7 @@ (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) @@ -848,21 +867,11 @@ (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. @@ -1594,7 +1603,7 @@ (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) @@ -1656,6 +1665,8 @@ (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) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 4f59a87..3e4ceaf 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -112,9 +112,9 @@ ;;; ;;; 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 @@ -442,8 +442,7 @@ (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)) @@ -708,7 +707,7 @@ (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)) @@ -832,15 +831,6 @@ ;;; 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)) @@ -854,13 +844,9 @@ (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)) @@ -953,7 +939,11 @@ (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) diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index 7e9171b..3929851 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -58,15 +58,6 @@ ((: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) @@ -99,9 +90,7 @@ ;;; 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))) @@ -109,54 +98,35 @@ (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 @@ -178,56 +148,47 @@ (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. @@ -236,18 +197,19 @@ ;;; 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)) @@ -256,41 +218,16 @@ (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)) ;;;; node-specific analysis functions @@ -315,8 +252,8 @@ ;;; 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))) @@ -329,16 +266,16 @@ (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)) @@ -346,14 +283,12 @@ ;;; 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 @@ -376,35 +311,33 @@ ;;; 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)) @@ -425,10 +358,10 @@ (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 @@ -438,8 +371,8 @@ ;;; 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))) @@ -447,17 +380,17 @@ (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 @@ -525,10 +458,6 @@ (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)))))) @@ -586,7 +515,6 @@ (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)) @@ -601,13 +529,7 @@ (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))))) @@ -788,8 +710,7 @@ (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)) @@ -818,37 +739,14 @@ . ,(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) @@ -887,17 +785,57 @@ (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)) + ;;;; interfaces @@ -910,31 +848,33 @@ (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)))) @@ -953,14 +893,12 @@ (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))))))) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index a86bbc9..1dd4bbc 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -100,30 +100,24 @@ ;;; 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))) ;;;; boolean attribute utilities ;;;; @@ -160,8 +154,8 @@ ;;; ;;; 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*")) @@ -462,13 +456,13 @@ ;;; 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)) @@ -476,7 +470,7 @@ (not (legal-fun-name-p name))) name (list name)) - '(function ,arg-types ,result-type) + '(sfunction ,arg-types ,result-type) (ir1-attributes ,@attributes) ,@keys)) @@ -619,6 +613,7 @@ `(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)) @@ -683,11 +678,6 @@ (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) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 8b63af8..0d6bebd 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1465,7 +1465,7 @@ (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 diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 83b3421..6b3bdd7 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -79,8 +79,6 @@ ;; 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)) @@ -102,33 +100,6 @@ ;; 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)) @@ -140,14 +111,14 @@ (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 @@ -157,7 +128,7 @@ ;; 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)) @@ -854,7 +825,7 @@ ;; 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 @@ -913,7 +884,7 @@ ;; 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))) @@ -1134,7 +1105,11 @@ ;;; 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)) @@ -1162,7 +1137,8 @@ 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) @@ -1259,6 +1235,30 @@ (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) ;;;; non-local exit support ;;;; diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 462e449..c1a53a9 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3373,7 +3373,7 @@ (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 diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index e198379..168d354 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -163,12 +163,12 @@ (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 @@ -200,8 +200,8 @@ ,(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) diff --git a/src/compiler/vop.lisp b/src/compiler/vop.lisp index fca025a..874c362 100644 --- a/src/compiler/vop.lisp +++ b/src/compiler/vop.lisp @@ -500,7 +500,7 @@ ;; 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. diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index a2efd33..5a8a202 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -385,8 +385,11 @@ (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) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index f36f860..71cce35 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -288,16 +288,22 @@ ;;; 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)) + ;;; BUG 48a. and b. (symbol-macrolet handling), fixed by Eric Marsden ;;; and Raymond Toy for CMUCL, fix ported for sbcl-0.7.6.18. @@ -312,13 +318,10 @@ *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))) -||# ;;; bug 120a: Turned out to be constraining code looking like (if foo ;;; ) where was optimized by the compiler to be the exact @@ -602,7 +605,6 @@ BUG 48c, not yet fixed: (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)) @@ -613,7 +615,6 @@ BUG 48c, not yet fixed: (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)) - ;;; INLINE inside MACROLET (declaim (inline to-be-inlined)) @@ -763,6 +764,30 @@ BUG 48c, not yet fixed: (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) @@ -790,6 +815,19 @@ BUG 48c, not yet fixed: (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))) + ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 74c91db..3918eab 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -232,7 +232,7 @@ (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))) @@ -342,6 +342,16 @@ ;;; 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))))))) diff --git a/version.lisp-expr b/version.lisp-expr index a4c5f45..88c9a2f 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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"