From: William Harold Newman Date: Thu, 22 Mar 2001 01:03:34 +0000 (+0000) Subject: 0.6.11.23: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=d147d512602d761a2dcdfded506dd1a8f9a140dc;p=sbcl.git 0.6.11.23: converted UNION :SIMPLE-SUBTYPEP method to use EVERY/TYPE made tests/type.*-xc.lisp dependent on :SB-TEST replaced ASSERT calls with AVER --- diff --git a/make-host-1.sh b/make-host-1.sh index f9e8f6a..bde0ae5 100644 --- a/make-host-1.sh +++ b/make-host-1.sh @@ -40,7 +40,8 @@ $SBCL_XC_HOST <<-'EOF' || exit 1 ;; Let's check that the type system is reasonably sane. (It's ;; easy to spend a long time wandering around confused trying ;; to debug cross-compilation if it isn't.) - (load "tests/type.before-xc.lisp") + (when (find :sb-test *shebang-features*) + (load "tests/type.before-xc.lisp")) (host-cload-stem "compiler/generic/genesis") (sb!vm:genesis :c-header-file-name "src/runtime/sbcl.h") EOF diff --git a/make-host-2.sh b/make-host-2.sh index cecfa18..8324a1c 100644 --- a/make-host-2.sh +++ b/make-host-2.sh @@ -106,7 +106,8 @@ $SBCL_XC_HOST <<-'EOF' || exit 1 ;; Let's check that the type system was reasonably sane. (It's ;; easy to spend a long time wandering around confused trying ;; to debug cold init if it wasn't.) - (load "tests/type.after-xc.lisp") + (when (find :sb-test *shebang-features*) + (load "tests/type.after-xc.lisp")) ;; If you're experimenting with the system under a ;; cross-compilation host which supports CMU-CL-style SAVE-LISP, ;; this can be a good time to run it. The resulting core isn't diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 00b5e5e..3746b0b 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -690,6 +690,7 @@ retained, possibly temporariliy, because it might be used internally." "ONCE-ONLY" "DEFENUM" "DEFPRINTER" + "AVER" ;; ..and DEFTYPEs.. "INDEX" diff --git a/src/code/byte-interp.lisp b/src/code/byte-interp.lisp index 53afca7..aaafdfa 100644 --- a/src/code/byte-interp.lisp +++ b/src/code/byte-interp.lisp @@ -1198,7 +1198,7 @@ (type stack-pointer more-args-start)) (cond ((not (hairy-byte-function-keywords-p xep)) - (assert restp) + (aver restp) (setf (current-stack-pointer) (1+ more-args-start)) (setf (eval-stack-ref more-args-start) rest)) (t diff --git a/src/code/class.lisp b/src/code/class.lisp index 5db094a..c25ae3b 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -410,7 +410,7 @@ (declaim (ftype (function (layout sb!xc:class index simple-vector layout-depthoid)) check-layout)) (defun check-layout (layout class length inherits depthoid) - (assert (eq (layout-class layout) class)) + (aver (eq (layout-class layout) class)) (when (redefine-layout-warning "current" layout "compile time" length inherits depthoid) ;; Classic CMU CL had more options here. There are several reasons @@ -468,12 +468,12 @@ ;; Attempting to register ourselves with a temporary undefined ;; class placeholder is almost certainly a programmer error. (I ;; should know, I did it.) -- WHN 19990927 - (assert (not (undefined-class-p class))) + (aver (not (undefined-class-p class))) ;; This assertion dates from classic CMU CL. The rationale is ;; probably that calling REGISTER-LAYOUT more than once for the ;; same LAYOUT is almost certainly a programmer error. - (assert (not (eq class-layout layout))) + (aver (not (eq class-layout layout))) ;; Figure out what classes are affected by the change, and issue ;; appropriate warnings and invalidations. @@ -667,11 +667,11 @@ ;;; the two classes are equal, since there are EQ checks in those ;;; operations. (!define-type-method (sb!xc:class :simple-=) (type1 type2) - (assert (not (eq type1 type2))) + (aver (not (eq type1 type2))) (values nil t)) (!define-type-method (sb!xc:class :simple-subtypep) (class1 class2) - (assert (not (eq class1 class2))) + (aver (not (eq class1 class2))) (let ((subclasses (class-subclasses class2))) (if (and subclasses (gethash class1 subclasses)) (values t t) diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index 40b785e..5a70e12 100644 --- a/src/code/cross-type.lisp +++ b/src/code/cross-type.lisp @@ -234,7 +234,7 @@ ;; that we don't continue doing it after we someday patch SBCL's ;; type system so that * is no longer a type, we make this ;; assertion: - (assert (typep (specifier-type '*) 'named-type)) + (aver (typep (specifier-type '*) 'named-type)) (values t t)) ;; Many simple types are guaranteed to correspond exactly ;; between any host ANSI Common Lisp and the target @@ -295,7 +295,7 @@ ;;; testing that range limits FOO and BAR in (INTEGER FOO BAR) are INTEGERs. (defun sb!xc:typep (host-object target-type-spec &optional (env nil env-p)) (declare (ignore env)) - (assert (null env-p)) ; 'cause we're too lazy to think about it + (aver (null env-p)) ; 'cause we're too lazy to think about it (multiple-value-bind (opinion certain-p) (cross-typep host-object target-type-spec) ;; A program that calls TYPEP doesn't want uncertainty and probably diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 15622b2..f610a0c 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -1078,7 +1078,7 @@ code (1+ real-lra-slot))) (setq code (code-header-ref code real-lra-slot)) ; (format t "ccf3 :bogus-lra ~S ~S~%" code pc-offset) - (assert code))) + (aver code))) (t ;; Not escaped (multiple-value-setq (pc-offset code) @@ -1994,7 +1994,7 @@ 0)) (sc-offset (if deleted 0 (geti))) (save-sc-offset (if save (geti) nil))) - (assert (not (and args-minimal (not minimal)))) + (aver (not (and args-minimal (not minimal)))) (vector-push-extend (make-compiled-debug-var symbol id live @@ -3182,7 +3182,7 @@ (when (code-location-unknown-p what) (error "cannot make a breakpoint at an unknown code location: ~S" what)) - (assert (eq kind :code-location)) + (aver (eq kind :code-location)) (let ((bpt (%make-breakpoint hook-function what kind info))) (etypecase what (interpreted-code-location @@ -3610,7 +3610,7 @@ offset)) (let ((breakpoints (breakpoint-data-breakpoints data))) (when breakpoints - (assert (eq (breakpoint-kind (car breakpoints)) :function-end)) + (aver (eq (breakpoint-kind (car breakpoints)) :function-end)) (handle-function-end-breakpoint-aux breakpoints data context))))) ;;; Either HANDLE-BREAKPOINT calls this for :FUNCTION-END breakpoints diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 1ebba15..ea374d1 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -465,7 +465,7 @@ Function and macro commands: (:rest ,@rest) (:keyword ,@keyword))) (symbol - (assert (eq ,element :deleted)) + (aver (eq ,element :deleted)) ,@deleted))) (sb!xc:defmacro lambda-var-dispatch (variable location deleted valid other) diff --git a/src/code/defbangstruct.lisp b/src/code/defbangstruct.lisp index e4d8a2e..67e669b 100644 --- a/src/code/defbangstruct.lisp +++ b/src/code/defbangstruct.lisp @@ -38,8 +38,8 @@ value)) (defun (setf def!struct-supertype) (value type) (when (and value #-sb-xc-host *type-system-initialized*) - (assert (subtypep value 'structure!object)) - (assert (subtypep type value))) + (aver (subtypep value 'structure!object)) + (aver (subtypep type value))) (setf (gethash type *def!struct-supertype*) value)) ;; (DEF!STRUCT-TYPE-MAKE-LOAD-FORM-FUN TYPE) is the load form @@ -67,7 +67,7 @@ type))))) (defun (setf def!struct-type-make-load-form-fun) (new-value type) (when #+sb-xc-host t #-sb-xc-host *type-system-initialized* - (assert (subtypep type 'structure!object)) + (aver (subtypep type 'structure!object)) (check-type new-value def!struct-type-make-load-form-fun)) (setf (gethash type *def!struct-type-make-load-form-fun*) new-value))) @@ -129,7 +129,7 @@ (when include-clause (setf def!struct-supertype (second include-clause))) (if (eq name 'structure!object) ; if root of hierarchy - (assert (not include-clause)) + (aver (not include-clause)) (unless include-clause (setf def!struct-supertype 'structure!object) (push `(:include ,def!struct-supertype) options))) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index c48bc58..384aab0 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -516,7 +516,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defun parse-name-and-options (name-and-options) (destructuring-bind (name &rest options) name-and-options - (assert name) ; A null name doesn't seem to make sense here. + (aver name) ; A null name doesn't seem to make sense here. (let ((defstruct (make-defstruct-description name))) (dolist (option options) (cond ((consp option) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 529844a..d8d0d63 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -389,8 +389,8 @@ `(unless ,expr (%failed-aver ,(let ((*package* (find-package :keyword))) (format nil "~S" expr))))) -(defun %failed-aver (expr) - (error "~@" expr)) +(defun %failed-aver (expr-as-string) + (error "~@" expr-as-string)) ;;;; utilities for two-VALUES predicates diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 3c5afcb..6f56179 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -628,7 +628,7 @@ (defun refill-fd-stream-buffer (stream) ;; We don't have any logic to preserve leftover bytes in the buffer, ;; so we should only be called when the buffer is empty. - (assert (= (fd-stream-ibuf-head stream) (fd-stream-ibuf-tail stream))) + (aver (= (fd-stream-ibuf-head stream) (fd-stream-ibuf-tail stream))) (multiple-value-bind (count err) (sb!unix:unix-read (fd-stream-fd stream) (fd-stream-ibuf-sap stream) diff --git a/src/code/float.lisp b/src/code/float.lisp index f9abfd9..cd661ae 100644 --- a/src/code/float.lisp +++ b/src/code/float.lisp @@ -789,7 +789,7 @@ (let* ((bits (ash bits -1)) (len (integer-length bits))) (cond ((> len digits) - (assert (= len (the fixnum (1+ digits)))) + (aver (= len (the fixnum (1+ digits)))) (scale-float (floatit (ash bits -1)) (1+ scale))) (t (scale-float (floatit bits) scale))))) @@ -809,7 +809,7 @@ (let ((extra (- (integer-length fraction-and-guard) digits))) (declare (fixnum extra)) (cond ((/= extra 1) - (assert (> extra 1))) + (aver (> extra 1))) ((oddp fraction-and-guard) (return (if (zerop rem) diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp index 016c921..9342340 100644 --- a/src/code/late-extensions.lisp +++ b/src/code/late-extensions.lisp @@ -83,7 +83,7 @@ ;; workaround for broken READ-SEQUENCE #+no-ansi-read-sequence (progn - (assert (<= start end)) + (aver (<= start end)) (let ((etype (stream-element-type stream))) (cond ((equal etype '(unsigned-byte 8)) (do ((i start (1+ i))) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 9bdafbb..326f744 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -679,7 +679,7 @@ (eql yx :no-type-method-found)) *empty-type*) (t - (assert (and (not xy) (not yx))) ; else handled above + (aver (and (not xy) (not yx))) ; else handled above nil)))))))) (defun-cached (type-intersection2 :hash-function type-cache-hash @@ -767,7 +767,7 @@ (declare (type function simplify2)) ;; Any input object satisfying %COMPOUND-TYPE-P should've been ;; broken into components before it reached us. - (assert (not (funcall %compound-type-p type))) + (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 @@ -900,30 +900,30 @@ ;; 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. - ;;(assert (not (eq type1 *wild-type*))) ; * isn't really a type. + ;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type. (values (eq type1 type2) t)) (!define-type-method (named :simple-subtypep) (type1 type2) - (assert (not (eq type1 *wild-type*))) ; * isn't really a type. + (aver (not (eq type1 *wild-type*))) ; * isn't really a type. (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t)) (!define-type-method (named :complex-subtypep-arg1) (type1 type2) - (assert (not (eq type1 *wild-type*))) ; * isn't really a type. + (aver (not (eq type1 *wild-type*))) ; * isn't really a type. ;; FIXME: Why does this (old CMU CL) assertion hold? Perhaps 'cause ;; the HAIRY-TYPE COMPLEX-SUBTYPEP-ARG2 method takes precedence over ;; this COMPLEX-SUBTYPE-ARG1 method? (I miss CLOS..) - (assert (not (hairy-type-p type2))) + (aver (not (hairy-type-p type2))) ;; Besides the old CMU CL assertion above, we also need to avoid ;; compound types, else we could get into trouble with ;; (SUBTYPEP 'T '(OR (SATISFIES FOO) (SATISFIES BAR))) ;; or ;; (SUBTYPEP 'T '(AND (SATISFIES FOO) (SATISFIES BAR))). - (assert (not (compound-type-p type2))) + (aver (not (compound-type-p type2))) ;; Then, since TYPE2 is reasonably tractable, we're good to go. (values (eq type1 *empty-type*) t)) (!define-type-method (named :complex-subtypep-arg2) (type1 type2) - (assert (not (eq type2 *wild-type*))) ; * isn't really a type. + (aver (not (eq type2 *wild-type*))) ; * isn't really a type. (cond ((eq type2 *universal-type*) (values t t)) ((hairy-type-p type1) @@ -938,12 +938,12 @@ (!define-type-method (named :complex-intersection2) (type1 type2) ;; FIXME: This assertion failed when I added it in sbcl-0.6.11.13. ;; Perhaps when bug 85 is fixed it can be reenabled. - ;;(assert (not (eq type2 *wild-type*))) ; * isn't really a type. + ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type. (hierarchical-intersection2 type1 type2)) (!define-type-method (named :complex-union2) (type1 type2) ;; Perhaps when bug 85 is fixed this can be reenabled. - ;;(assert (not (eq type2 *wild-type*))) ; * isn't really a type. + ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type. (hierarchical-union2 type1 type2)) (!define-type-method (named :unparse) (x) @@ -1094,7 +1094,7 @@ 'complex `(complex ,base+bounds))) ((nil) - (assert (eq base+bounds 'real)) + (aver (eq base+bounds 'real)) 'number))))) ;;; Return true if X is "less than or equal" to Y, taking open bounds @@ -1896,7 +1896,7 @@ ;;;; ;; reasonable definition ;;;; (DEFTYPE KEYWORD () '(AND SYMBOL (SATISFIES KEYWORDP))) ;;;; ;; reasonable behavior -;;;; (ASSERT (SUBTYPEP 'KEYWORD 'SYMBOL)) +;;;; (AVER (SUBTYPEP 'KEYWORD 'SYMBOL)) ;;;; Without understanding a little about the semantics of AND, we'd ;;;; get (SUBTYPEP 'KEYWORD 'SYMBOL)=>NIL,NIL and, for entirely ;;;; parallel reasons, (SUBTYPEP 'RATIO 'NUMBER)=>NIL,NIL. That's @@ -1977,23 +1977,10 @@ ;;; Similarly, a union type is a subtype of another if every element ;;; of TYPE1 is a subtype of some element of TYPE2. -;;; -;;; KLUDGE: This definition seems redundant, here in UNION-TYPE and -;;; similarly in INTERSECTION-TYPE, with the logic in the -;;; corresponding :COMPLEX-SUBTYPEP-ARG1 and :COMPLEX-SUBTYPEP-ARG2 -;;; methods. Ideally there's probably some way to make the -;;; :SIMPLE-SUBTYPEP method default to the :COMPLEX-SUBTYPEP-FOO -;;; methods in such a way that this definition could go away, but I -;;; don't grok the system well enough to tell whether it's simple to -;;; arrange this. -- WHN 2000-02-03 (!define-type-method (union :simple-subtypep) (type1 type2) - (dolist (t1 (union-type-types type1) (values t t)) - (multiple-value-bind (subtypep validp) - (union-complex-subtypep-arg2 t1 type2) - (cond ((not validp) - (return (values nil nil))) - ((not subtypep) - (return (values nil t))))))) + (every/type (swapped-args-fun #'union-complex-subtypep-arg2) + type2 + (union-type-types type1))) (defun union-complex-subtypep-arg1 (type1 type2) (every/type (swapped-args-fun #'csubtypep) diff --git a/src/code/macros.lisp b/src/code/macros.lisp index b8fcd1b..d4731bb 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -157,7 +157,7 @@ (defun sb!c::%define-compiler-macro (name definition lambda-list doc) ;; FIXME: Why does this have to be an interpreted function? Shouldn't ;; it get compiled? - (assert (sb!eval:interpreted-function-p definition)) + (aver (sb!eval:interpreted-function-p definition)) (setf (sb!eval:interpreted-function-name definition) (format nil "DEFINE-COMPILER-MACRO ~S" name)) (setf (sb!eval:interpreted-function-arglist definition) lambda-list) diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 7dcc7ea..32661aa 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -661,7 +661,7 @@ (declare (fixnum esc)) (cond ((< esc i) t) (t - (assert (= esc i)) + (aver (= esc i)) (pop escapes) nil)))) (let ((ch (schar *read-buffer* i))) diff --git a/src/code/room.lisp b/src/code/room.lisp index 4ba273d..17c2cec 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -198,7 +198,7 @@ (* (+ (%instance-length obj) 1) word-bytes)))) (declare (fixnum size)) (funcall fun obj header-type size) - (assert (zerop (logand size lowtag-mask))) + (aver (zerop (logand size lowtag-mask))) #+nil (when (> size 200000) (break "implausible size, prev ~S" prev)) #+nil @@ -209,7 +209,7 @@ (logior (sap-int current) other-pointer-type))) (size (ecase (room-info-kind info) (:fixed - (assert (or (eql (room-info-length info) + (aver (or (eql (room-info-length info) (1+ (get-header-data obj))) (floatp obj))) (round-to-dualword @@ -227,7 +227,7 @@ word-bytes))))))) (declare (fixnum size)) (funcall fun obj header-type size) - (assert (zerop (logand size lowtag-mask))) + (aver (zerop (logand size lowtag-mask))) #+nil (when (> size 200000) (break "Implausible size, prev ~S" prev)) @@ -235,7 +235,7 @@ (setq prev current) (setq current (sap+ current size)))))) (unless (sap< current end) - (assert (sap= current end)) + (aver (sap= current end)) (return))) #+nil diff --git a/src/code/serve-event.lisp b/src/code/serve-event.lisp index 9060748..299d4f7 100644 --- a/src/code/serve-event.lisp +++ b/src/code/serve-event.lisp @@ -86,9 +86,9 @@ "Arange to call FUNCTION whenever FD is usable. DIRECTION should be either :INPUT or :OUTPUT. The value returned should be passed to SYSTEM:REMOVE-FD-HANDLER when it is no longer needed." - (assert (member direction '(:input :output)) - (direction) - "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction) + (unless (member direction '(:input :output)) + ;; FIXME: should be TYPE-ERROR? + (error "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction)) (let ((handler (make-handler direction fd function))) (push handler *descriptor-handlers*) handler)) diff --git a/src/code/setf-funs.lisp b/src/code/setf-funs.lisp index 4073fc8..f26996b 100644 --- a/src/code/setf-funs.lisp +++ b/src/code/setf-funs.lisp @@ -43,7 +43,7 @@ (info :setf :expander sym)) (not (member sym ignore))) (let ((type (type-specifier (info :function :type sym)))) - (assert (consp type)) + (aver (consp type)) #!-sb-fluid (res `(declaim (inline (setf ,sym)))) (res (compute-one-setter sym type)))))) `(progn ,@(res)))) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 76d33bb..cccdba4 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -541,7 +541,7 @@ ;; spec, and extrapolating from the behavior of other operations ;; when their operands are the wrong type, it seems that it would be ;; more correct to essentially - ;; (ASSERT (<= 0 START END (LENGTH STRING))) + ;; (AVER (<= 0 START END (LENGTH STRING))) ;; instead of modifying the incorrect values. #!+high-security (setf end (min end (length (the vector string)))) diff --git a/src/code/target-eval.lisp b/src/code/target-eval.lisp index 17e2663..f518110 100644 --- a/src/code/target-eval.lisp +++ b/src/code/target-eval.lisp @@ -84,7 +84,7 @@ ;;;; debuggable macros anyway). In that environment, a stub no-op version of ;;;; this function is used. (defun try-to-rename-interpreted-function-as-macro (f name lambda-list) - (assert (sb!eval:interpreted-function-p f)) + (aver (sb!eval:interpreted-function-p f)) (setf (sb!eval:interpreted-function-name f) (format nil "DEFMACRO ~S" name) (sb!eval:interpreted-function-arglist f) diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp index 844729c..a5dbf26 100644 --- a/src/code/target-hash-table.lisp +++ b/src/code/target-hash-table.lisp @@ -429,7 +429,7 @@ (defun %puthash (key hash-table value) (declare (type hash-table hash-table)) - (assert (hash-table-index-vector hash-table)) + (aver (hash-table-index-vector hash-table)) (without-gcing ;; We need to rehash here so that a current key can be found if it ;; exists. Check that there is room for one more entry. May not be @@ -483,7 +483,7 @@ ;; Pop a KV slot off the free list (let ((free-kv-slot (hash-table-next-free-kv hash-table))) ;; Double-check for overflow. - (assert (not (zerop free-kv-slot))) + (aver (not (zerop free-kv-slot))) (setf (hash-table-next-free-kv hash-table) (aref next-vector free-kv-slot)) (incf (hash-table-number-entries hash-table)) @@ -495,7 +495,7 @@ (when hash-vector (if (not eq-based) (setf (aref hash-vector free-kv-slot) hashing) - (assert (= (aref hash-vector free-kv-slot) #x80000000)))) + (aver (= (aref hash-vector free-kv-slot) #x80000000)))) ;; Push this slot into the next chain. (setf (aref next-vector free-kv-slot) next) @@ -617,7 +617,7 @@ (do ((i 2 (1+ i))) ((>= i kv-length)) (setf (aref kv-vector i) +empty-ht-slot+)) - (assert (eq (aref kv-vector 0) hash-table)) + (aver (eq (aref kv-vector 0) hash-table)) ;; Set up the free list, all free. (do ((i 1 (1+ i))) ((>= i (1- size))) diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 4bf4b3f..c8f6756 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -959,7 +959,7 @@ ;; nicknames that we don't want in our target SBCL. For that reason, ;; we handle it specially, not dumping the host Lisp version at ;; genesis time.. - (assert (not (find-package "COMMON-LISP-USER"))) + (aver (not (find-package "COMMON-LISP-USER"))) ;; ..but instead making our own from scratch here. (/show0 "about to MAKE-PACKAGE COMMON-LISP-USER") (make-package "COMMON-LISP-USER" diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 39dadfb..e10d251 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -1000,14 +1000,14 @@ a host-structure or string." (dolist (to-part (rest to)) (typecase to-part ((member :wild) - (assert subs-left) + (aver subs-left) (let ((match (pop subs-left))) (when (listp match) (error ":WILD-INFERIORS is not paired in from and to ~ patterns:~% ~S ~S" from to)) (res (maybe-diddle-case match diddle-case)))) ((member :wild-inferiors) - (assert subs-left) + (aver subs-left) (let ((match (pop subs-left))) (unless (listp match) (error ":WILD-INFERIORS not paired in from and to ~ @@ -1304,7 +1304,7 @@ a host-structure or string." (return) (pattern :multi-char-wild)) (setq last-pos (1+ pos))))) - (assert (pattern)) + (aver (pattern)) (if (cdr (pattern)) (make-pattern (pattern)) (let ((x (car (pattern)))) diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp index 7018c33..5501cdd 100644 --- a/src/compiler/aliencomp.lisp +++ b/src/compiler/aliencomp.lisp @@ -667,10 +667,9 @@ #!-x86 (temp-tn (make-representation-tn (tn-primitive-type tn) scn)) (move-arg-vops (svref (sc-move-arg-vops sc) scn))) - (assert arg) - (assert (= (length move-arg-vops) 1) () - "no unique move-arg-vop for moves in SC ~S" - (sc-name sc)) + (aver arg) + (unless (= (length move-arg-vops) 1) + (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc))) #!+x86 (emit-move-arg-template call block (first move-arg-vops) @@ -688,7 +687,7 @@ temp-tn nsp tn)))) - (assert (null args)) + (aver (null args)) (unless (listp result-tns) (setf result-tns (list result-tns))) (vop* call-out call block diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index 79b992a..a6137b0 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -311,12 +311,12 @@ (inst-write-dependencies inst)) (writes write)) (writes))) - (assert (segment-run-scheduler segment)) + (aver (segment-run-scheduler segment)) (let ((countdown (segment-branch-countdown segment))) (when countdown (decf countdown) - (assert (not (instruction-attributep (inst-attributes inst) - variable-length)))) + (aver (not (instruction-attributep (inst-attributes inst) + variable-length)))) (cond ((instruction-attributep (inst-attributes inst) branch) (unless countdown (setf countdown (inst-delay inst))) @@ -336,7 +336,7 @@ ;;; instructions would sit there until the scheduler was turned back ;;; on, and emitted in the wrong place). (defun schedule-pending-instructions (segment) - (assert (segment-run-scheduler segment)) + (aver (segment-run-scheduler segment)) ;; Quick blow-out if nothing to do. (when (and (sset-empty (segment-emittable-insts-sset segment)) @@ -565,8 +565,8 @@ p ;; the branch has two dependents and one of them dpends on ;;; remove this instruction from their dependents list. If we were the ;;; last dependent, then that dependency can be emitted now. (defun note-resolved-dependencies (segment inst) - (assert (sset-empty (inst-read-dependents inst))) - (assert (sset-empty (inst-write-dependents inst))) + (aver (sset-empty (inst-read-dependents inst))) + (aver (sset-empty (inst-write-dependents inst))) (do-sset-elements (dep (inst-write-dependencies inst)) ;; These are the instructions who have to be completed before our ;; write fires. Doesn't matter how far before, just before. @@ -853,7 +853,7 @@ p ;; the branch has two dependents and one of them dpends on (emit-skip segment (- (ash 1 alignment) slop) fill-byte))) (let ((size (logand (1- (ash 1 bits)) (lognot (1- (ash 1 alignment)))))) - (assert (> size 0)) + (aver (> size 0)) (emit-annotation segment (make-alignment bits size fill-byte)) (emit-skip segment size fill-byte)) (setf (segment-alignment segment) bits) @@ -998,7 +998,7 @@ p ;; the branch has two dependents and one of them dpends on (size (- new-posn posn)) (old-size (alignment-size note)) (additional-delta (- old-size size))) - (assert (<= 0 size old-size)) + (aver (<= 0 size old-size)) (unless (zerop additional-delta) (setf (segment-last-annotation segment) prev) (incf delta additional-delta) @@ -1387,7 +1387,7 @@ p ;; the branch has two dependents and one of them dpends on (let ((forms nil)) (dotimes (i num-bytes) (let ((pieces (svref bytes i))) - (assert pieces) + (aver pieces) (push `(emit-byte ,segment-arg ,(if (cdr pieces) `(logior ,@pieces) diff --git a/src/compiler/byte-comp.lisp b/src/compiler/byte-comp.lisp index db5be90..912ea91 100644 --- a/src/compiler/byte-comp.lisp +++ b/src/compiler/byte-comp.lisp @@ -78,7 +78,7 @@ (declare (type sb!assem:segment segment) (ignore posn)) (let ((target (sb!assem:label-position label))) - (assert (<= 0 target (1- (ash 1 24)))) + (aver (<= 0 target (1- (ash 1 24)))) (output-byte segment (ldb (byte 8 16) target)) (output-byte segment (ldb (byte 8 8) target)) (output-byte segment (ldb (byte 8 0) target)))))) @@ -116,7 +116,7 @@ (declare (type sb!assem:segment segment) (ignore posn)) (let ((target (sb!assem:label-position label))) - (assert (<= 0 target (1- (ash 1 24)))) + (aver (<= 0 target (1- (ash 1 24)))) (output-byte segment kind) (output-byte segment (ldb (byte 8 16) target)) (output-byte segment (ldb (byte 8 8) target)) @@ -362,7 +362,7 @@ ;; times on the same continuation. So we can't assert that we ;; haven't done it. #+nil - (assert (null (continuation-info cont))) + (aver (null (continuation-info cont))) (setf (continuation-info cont) (make-byte-continuation-info cont results placeholders)) (values)) @@ -467,7 +467,7 @@ (if (continuation-function-name fun) :fdefinition 1)))) (cond ((mv-combination-p call) (cond ((eq name '%throw) - (assert (= (length args) 2)) + (aver (= (length args) 2)) (annotate-continuation (first args) 1) (annotate-continuation (second args) :unknown) (setf (node-tail-p call) nil) @@ -610,7 +610,7 @@ (consume (cont) (cond ((not (or (eq cont :nlx-entry) (interesting cont)))) (stack - (assert (eq (car stack) cont)) + (aver (eq (car stack) cont)) (pop stack)) (t (adjoin-cont cont total-consumes) @@ -705,10 +705,10 @@ (let ((new-stack stack)) (dolist (cont stuff) (cond ((eq cont :nlx-entry) - (assert (find :nlx-entry new-stack)) + (aver (find :nlx-entry new-stack)) (setq new-stack (remove :nlx-entry new-stack :count 1))) (t - (assert (eq (car new-stack) cont)) + (aver (eq (car new-stack) cont)) (pop new-stack)))) new-stack)) @@ -756,7 +756,7 @@ (incf fixed results)))))) (flush-fixed))) (when (pops) - (assert pred) + (aver pred) (let ((cleanup-block (insert-cleanup-code pred block (continuation-next (block-start block)) @@ -779,7 +779,7 @@ (t ;; We have already processed the successors of this block. Just ;; make sure we thing the stack is the same now as before. - (assert (equal (byte-block-info-start-stack info) stack))))) + (aver (equal (byte-block-info-start-stack info) stack))))) (values)) ;;; Do lifetime flow analysis on values pushed on the stack, then call @@ -1003,8 +1003,8 @@ (cond ((not (eq (lambda-environment (lambda-var-home var)) env)) ;; This is not this guy's home environment. So we need to ;; get it the value cell out of the closure, and fill it in. - (assert indirect) - (assert (not make-value-cells)) + (aver indirect) + (aver (not make-value-cells)) (output-byte-with-operand segment byte-push-arg (closure-position var env)) (output-do-inline-function segment 'value-cell-setf)) @@ -1012,7 +1012,7 @@ (let* ((pushp (and indirect (not make-value-cells))) (byte-code (if pushp byte-push-local byte-pop-local)) (info (leaf-info var))) - (assert (not (byte-lambda-var-info-argp info))) + (aver (not (byte-lambda-var-info-argp info))) (when (and indirect make-value-cells) ;; Replace the stack top with a value cell holding the ;; stack top. @@ -1083,7 +1083,7 @@ (let ((desired (byte-continuation-info-results info)) (placeholders (byte-continuation-info-placeholders info))) (unless (zerop placeholders) - (assert (eql desired (1+ placeholders))) + (aver (eql desired (1+ placeholders))) (setq desired 1)) (flet ((do-check () @@ -1207,9 +1207,9 @@ (leaf (ref-leaf ref))) (cond ((eq values :fdefinition) - (assert (and (global-var-p leaf) - (eq (global-var-kind leaf) - :global-function))) + (aver (and (global-var-p leaf) + (eq (global-var-kind leaf) + :global-function))) (let* ((name (global-var-name leaf)) (found (gethash name *two-arg-functions*))) (output-push-fdefinition @@ -1311,7 +1311,7 @@ (output-set-lambda-var segment var env t)))) ((nil :optional :cleanup) ;; We got us a local call. - (assert (not (eq num-args :unknown))) + (aver (not (eq num-args :unknown))) ;; Push any trailing placeholder args... (dolist (x (reverse (basic-combination-args call))) (when x (return)) @@ -1367,7 +1367,7 @@ (cond (info ;; It's an inline function. - (assert (not (node-tail-p call))) + (aver (not (node-tail-p call))) (let* ((type (inline-function-info-type info)) (desired-args (function-type-nargs type)) (supplied-results @@ -1375,7 +1375,7 @@ (values-types (function-type-returns type)))) (leaf (ref-leaf (continuation-use (basic-combination-fun call))))) (cond ((slot-accessor-p leaf) - (assert (= num-args (1- desired-args))) + (aver (= num-args (1- desired-args))) (output-push-int segment (dsd-index (slot-accessor-slot leaf)))) (t (canonicalize-values segment desired-args num-args))) @@ -1422,10 +1422,10 @@ 0)) num-args segment) (return)) - (assert (member (byte-continuation-info-results - (continuation-info - (basic-combination-fun call))) - '(1 :fdefinition))) + (aver (member (byte-continuation-info-results + (continuation-info + (basic-combination-fun call))) + '(1 :fdefinition))) (generate-byte-code-for-full-call segment call cont num-args)) (values)) @@ -1631,8 +1631,8 @@ (progn segment) ; ignorable. ;; We don't have to do anything, because everything is handled by ;; the IF byte-generator. - (assert (eq results :eq-test)) - (assert (eql num-args 2)) + (aver (eq results :eq-test)) + (aver (eql num-args 2)) (values)) (defoptimizer (values byte-compile) @@ -1642,7 +1642,7 @@ (defknown %byte-pop-stack (index) (values)) (defoptimizer (%byte-pop-stack byte-annotate) ((count) node) - (assert (constant-continuation-p count)) + (aver (constant-continuation-p count)) (annotate-continuation count 0) (annotate-continuation (basic-combination-fun node) 0) (setf (node-tail-p node) nil) @@ -1650,7 +1650,7 @@ (defoptimizer (%byte-pop-stack byte-compile) ((count) node results num-args segment) - (assert (and (zerop num-args) (zerop results))) + (aver (and (zerop num-args) (zerop results))) (output-byte-with-operand segment byte-pop-n (continuation-value count))) (defoptimizer (%special-bind byte-annotate) ((var value) node) @@ -1662,7 +1662,7 @@ (defoptimizer (%special-bind byte-compile) ((var value) node results num-args segment) - (assert (and (eql num-args 1) (zerop results))) + (aver (and (eql num-args 1) (zerop results))) (output-push-constant segment (leaf-name (continuation-value var))) (output-do-inline-function segment '%byte-special-bind)) @@ -1674,7 +1674,7 @@ (defoptimizer (%special-unbind byte-compile) ((var) node results num-args segment) - (assert (and (zerop num-args) (zerop results))) + (aver (and (zerop num-args) (zerop results))) (output-do-inline-function segment '%byte-special-unbind)) (defoptimizer (%catch byte-annotate) ((nlx-info tag) node) @@ -1687,18 +1687,18 @@ (defoptimizer (%catch byte-compile) ((nlx-info tag) node results num-args segment) (progn node) ; ignore - (assert (and (= num-args 1) (zerop results))) + (aver (and (= num-args 1) (zerop results))) (output-do-xop segment 'catch) (let ((info (nlx-info-info (continuation-value nlx-info)))) (output-reference segment (byte-nlx-info-label info)))) (defoptimizer (%cleanup-point byte-compile) (() node results num-args segment) (progn node segment) ; ignore - (assert (and (zerop num-args) (zerop results)))) + (aver (and (zerop num-args) (zerop results)))) (defoptimizer (%catch-breakup byte-compile) (() node results num-args segment) (progn node) ; ignore - (assert (and (zerop num-args) (zerop results))) + (aver (and (zerop num-args) (zerop results))) (output-do-xop segment 'breakup)) (defoptimizer (%lexical-exit-breakup byte-annotate) ((nlx-info) node) @@ -1709,7 +1709,7 @@ (defoptimizer (%lexical-exit-breakup byte-compile) ((nlx-info) node results num-args segment) - (assert (and (zerop num-args) (zerop results))) + (aver (and (zerop num-args) (zerop results))) (let ((nlx-info (continuation-value nlx-info))) (when (ecase (cleanup-kind (nlx-info-cleanup nlx-info)) (:block @@ -1730,7 +1730,7 @@ (defoptimizer (%nlx-entry byte-compile) ((nlx-info) node results num-args segment) (progn node results) ; ignore - (assert (eql num-args 0)) + (aver (eql num-args 0)) (let* ((info (continuation-value nlx-info)) (byte-info (nlx-info-info info))) (output-label segment (byte-nlx-info-label byte-info)) @@ -1752,7 +1752,7 @@ (defoptimizer (%unwind-protect byte-compile) ((nlx-info cleanup-fun) node results num-args segment) - (assert (and (zerop num-args) (zerop results))) + (aver (and (zerop num-args) (zerop results))) (output-do-xop segment 'unwind-protect) (output-reference segment (byte-nlx-info-label @@ -1762,7 +1762,7 @@ (defoptimizer (%unwind-protect-breakup byte-compile) (() node results num-args segment) (progn node) ; ignore - (assert (and (zerop num-args) (zerop results))) + (aver (and (zerop num-args) (zerop results))) (output-do-xop segment 'breakup)) (defoptimizer (%continue-unwind byte-annotate) ((a b c) node) @@ -1776,8 +1776,8 @@ (defoptimizer (%continue-unwind byte-compile) ((a b c) node results num-args segment) (progn node) ; ignore - (assert (member results '(0 nil))) - (assert (eql num-args 0)) + (aver (member results '(0 nil))) + (aver (eql num-args 0)) (output-do-xop segment 'breakup)) (defoptimizer (%load-time-value byte-annotate) ((handle) node) @@ -1789,7 +1789,7 @@ (defoptimizer (%load-time-value byte-compile) ((handle) node results num-args segment) (progn node) ; ignore - (assert (zerop num-args)) + (aver (zerop num-args)) (output-push-load-time-constant segment :load-time-value (continuation-value handle)) (canonicalize-values segment results 1)) @@ -1798,7 +1798,7 @@ (defun make-xep-for (lambda) (flet ((entry-point-for (entry) (let ((info (lambda-info entry))) - (assert (byte-lambda-info-interesting info)) + (aver (byte-lambda-info-interesting info)) (sb!assem:label-position (byte-lambda-info-label info))))) (let ((entry (lambda-entry-function lambda))) (etypecase entry @@ -1810,10 +1810,10 @@ (dolist (var (nthcdr (optional-dispatch-max-args entry) (optional-dispatch-arglist entry))) (let ((arg-info (lambda-var-arg-info var))) - (assert arg-info) + (aver arg-info) (ecase (arg-info-kind arg-info) (:rest - (assert (not rest-arg-p)) + (aver (not rest-arg-p)) (incf num-more) (setf rest-arg-p t)) (:keyword diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 9221be2..3c0303d 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -214,7 +214,7 @@ (declare (type continuation cont)) (let ((type (continuation-asserted-type cont)) (dest (continuation-dest cont))) - (assert (not (eq type *wild-type*))) + (aver (not (eq type *wild-type*))) (multiple-value-bind (types count) (no-function-values-types type) (cond ((not (eq count :unknown)) (if (or (exit-p dest) @@ -227,7 +227,7 @@ (maybe-negate-check cont types nil))) ((and (mv-combination-p dest) (eq (basic-combination-kind dest) :local)) - (assert (values-type-p type)) + (aver (values-type-p type)) (maybe-negate-check cont (args-type-optional type) nil)) (t (values :too-hairy nil)))))) @@ -353,7 +353,7 @@ (ir1-convert new-start dummy (make-type-check-form types)) ;; TO DO: Why should this be true? -- WHN 19990601 - (assert (eq (continuation-block dummy) new-block)) + (aver (eq (continuation-block dummy) new-block)) ;; KLUDGE: Comments at the head of this function in CMU CL ;; said that somewhere in here we @@ -385,7 +385,7 @@ (let* ((node (continuation-use cont)) (args (basic-combination-args node)) (victim (first args))) - (assert (and (= (length args) 1) + (aver (and (= (length args) 1) (eq (constant-value (ref-leaf (continuation-use victim))) diff --git a/src/compiler/control.lisp b/src/compiler/control.lisp index 91ff7db..ce58695 100644 --- a/src/compiler/control.lisp +++ b/src/compiler/control.lisp @@ -73,7 +73,7 @@ (> (block-number pred) current-num)) (setq current pred current-num (block-number pred)) (return))))) - (assert (not (block-flag current))) + (aver (not (block-flag current))) current)) (t block)))) @@ -100,7 +100,7 @@ (unless (block-flag block) (let ((block (find-rotated-loop-head block))) (setf (block-flag block) t) - (assert (and (block-component block) (not (block-delete-p block)))) + (aver (and (block-component block) (not (block-delete-p block)))) (add-to-emit-order (or (block-info block) (setf (block-info block) (funcall block-info-constructor block))) diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 0a4ddd4..1cf4f85 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -244,7 +244,7 @@ ;;; we need them or not. (defun debug-source-for-info (info) (declare (type source-info info)) - (assert (not (source-info-current-file info))) + (aver (not (source-info-current-file info))) (mapcar #'(lambda (x) (let ((res (make-debug-source :from :file @@ -346,7 +346,7 @@ (vector-push-extend id buffer))) (if tn (vector-push-extend (tn-sc-offset tn) buffer) - (assert minimal)) + (aver minimal)) (when save-tn (vector-push-extend (tn-sc-offset save-tn) buffer))) (values)) @@ -415,8 +415,8 @@ (let ((res (gethash var var-locs))) (cond (res) (t - (assert (or (null (leaf-refs var)) - (not (tn-offset (leaf-info var))))) + (aver (or (null (leaf-refs var)) + (not (tn-offset (leaf-info var))))) 'deleted)))) ;;;; arguments/returns @@ -567,7 +567,7 @@ minimal-debug-function-name-symbol) (t minimal-debug-function-name-packaged)))) - (assert (or (atom name) setf-p)) + (aver (or (atom name) setf-p)) (let ((options 0)) (setf (ldb minimal-debug-function-name-style-byte options) name-rep) (setf (ldb minimal-debug-function-kind-byte options) diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index ae00cdb..371777f 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -910,7 +910,7 @@ (optional-dispatch (format stream "optional-dispatch ~S" (leaf-name leaf))) (functional - (assert (eq (functional-kind leaf) :top-level-xep)) + (aver (eq (functional-kind leaf) :top-level-xep)) (format stream "TL-XEP ~S" (let ((info (leaf-info leaf))) (etypecase info @@ -1141,11 +1141,10 @@ (clrhash *list-conflicts-table*) (res))) +;;; Return a list of a the TNs that conflict with TN. Sort of, kind +;;; of. For debugging use only. Probably doesn't work on :COMPONENT TNs. (defun list-conflicts (tn) - #!+sb-doc - "Return a list of a the TNs that conflict with TN. Sort of, kind of. For - debugging use only. Probably doesn't work on :COMPONENT TNs." - (assert (member (tn-kind tn) '(:normal :environment :debug-environment))) + (aver (member (tn-kind tn) '(:normal :environment :debug-environment))) (let ((confs (tn-global-conflicts tn))) (cond (confs (clrhash *list-conflicts-table*) diff --git a/src/compiler/dfo.lisp b/src/compiler/dfo.lisp index 85507eb..dd304c7 100644 --- a/src/compiler/dfo.lisp +++ b/src/compiler/dfo.lisp @@ -44,7 +44,7 @@ ;;; before FIND-INITIAL-DFO runs.] (declaim (ftype (function (component component) (values)) join-components)) (defun join-components (new old) - (assert (eq (component-kind new) (component-kind old))) + (aver (eq (component-kind new) (component-kind old))) (let ((old-head (component-head old)) (old-tail (component-tail old)) (head (component-head new)) @@ -304,15 +304,15 @@ (dolist (tll lambdas) (let ((component (block-component (node-block (lambda-bind tll))))) (dolist (fun (component-lambdas component)) - (assert (member (functional-kind fun) - '(:optional :external :top-level nil :escape - :cleanup))) + (aver (member (functional-kind fun) + '(:optional :external :top-level nil :escape + :cleanup))) (let ((res (dfo-walk-call-graph fun new))) (when (eq res new) (components new) (setq new (make-empty-component))))) (when (eq (component-kind component) :initial) - (assert (null (component-lambdas component))) + (aver (null (component-lambdas component))) (let ((tail (component-tail component))) (dolist (pred (block-pred tail)) (let ((pred-component (block-component pred))) @@ -378,12 +378,12 @@ (unlink-blocks pred tail) (let ((last (block-last pred))) (unless (return-p last) - (assert (basic-combination-p last)) + (aver (basic-combination-p last)) (link-blocks pred (component-tail result-component)))))) (let ((lambdas (component-lambdas component))) - (assert (and (null (rest lambdas)) - (eq (first lambdas) lambda)))) + (aver (and (null (rest lambdas)) + (eq (first lambdas) lambda)))) ;; Switch the end of the code from the return block to the start of ;; the next chunk. diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index e883864..87f72ec 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -226,7 +226,7 @@ (defun note-potential-circularity (x file) (unless *cold-load-dump* (let ((circ (fasl-file-circularity-table file))) - (assert (not (gethash x circ))) + (aver (not (gethash x circ))) (setf (gethash x circ) x))) (values)) @@ -297,7 +297,7 @@ ;;; We do various sanity checks, then end the group. (defun close-fasl-file (file abort-p) (declare (type fasl-file file)) - (assert (zerop (hash-table-count (fasl-file-patch-table file)))) + (aver (zerop (hash-table-count (fasl-file-patch-table file)))) (dump-fop 'sb!impl::fop-verify-empty-stack file) (dump-fop 'sb!impl::fop-verify-table-size file) (dump-unsigned-32 (fasl-file-table-free file) file) @@ -462,7 +462,7 @@ (defun fasl-dump-load-time-value-lambda (fun file) (declare (type clambda fun) (type fasl-file file)) (let ((handle (gethash (leaf-info fun) (fasl-file-entry-table file)))) - (assert handle) + (aver handle) (dump-push handle file) (dump-fop 'sb!impl::fop-funcall file) (dump-byte 0 file)) @@ -612,8 +612,8 @@ ;;; Marking of the conses is inhibited when *COLD-LOAD-DUMP* is true. ;;; This inhibits all circularity detection. (defun dump-list (list file) - (assert (and list - (not (gethash list (fasl-file-circularity-table file))))) + (aver (and list + (not (gethash list (fasl-file-circularity-table file))))) (do* ((l list (cdr l)) (n 0 (1+ n)) (circ (fasl-file-circularity-table file))) @@ -786,7 +786,7 @@ ;; unportable bit bashing. (cond ((>= size 8) ; easy cases (multiple-value-bind (floor rem) (floor size 8) - (assert (zerop rem)) + (aver (zerop rem)) (dovector (i vec) (dump-integer-as-n-bytes i floor file)))) (t ; harder cases, not supported in cross-compiler @@ -959,22 +959,22 @@ ;; noise before the offset. (ecase flavor (:assembly-routine - (assert (symbolp name)) + (aver (symbolp name)) (dump-fop 'sb!impl::fop-normal-load fasl-file) (let ((*cold-load-dump* t)) (dump-object name fasl-file)) (dump-fop 'sb!impl::fop-maybe-cold-load fasl-file) (dump-fop 'sb!impl::fop-assembler-fixup fasl-file)) (:foreign - (assert (stringp name)) + (aver (stringp name)) (dump-fop 'sb!impl::fop-foreign-fixup fasl-file) (let ((len (length name))) - (assert (< len 256)) ; (limit imposed by fop definition) + (aver (< len 256)) ; (limit imposed by fop definition) (dump-byte len fasl-file) (dotimes (i len) (dump-byte (char-code (schar name i)) fasl-file)))) (:code-object - (assert (null name)) + (aver (null name)) (dump-fop 'sb!impl::fop-code-object-fixup fasl-file))) ;; No matter what the flavor, we'll always dump the offset. (dump-unsigned-32 offset fasl-file))) @@ -1330,7 +1330,7 @@ (defun fasl-dump-top-level-lambda-call (fun file) (declare (type clambda fun) (type fasl-file file)) (let ((handle (gethash (leaf-info fun) (fasl-file-entry-table file)))) - (assert handle) + (aver handle) (dump-push handle file) (dump-fop 'sb!impl::fop-funcall-for-effect file) (dump-byte 0 file)) diff --git a/src/compiler/entry.lisp b/src/compiler/entry.lisp index fdbd985..e0c9b8d 100644 --- a/src/compiler/entry.lisp +++ b/src/compiler/entry.lisp @@ -40,7 +40,7 @@ (defun make-arg-names (x) (declare (type functional x)) (let ((args (functional-arg-documentation x))) - (assert (not (eq args :unspecified))) + (aver (not (eq args :unspecified))) (if (null args) "()" (let ((*print-pretty* t) diff --git a/src/compiler/envanal.lisp b/src/compiler/envanal.lisp index 80cc63c..f6d353c 100644 --- a/src/compiler/envanal.lisp +++ b/src/compiler/envanal.lisp @@ -30,9 +30,9 @@ ;;; that the XEP doesn't. (defun environment-analyze (component) (declare (type component component)) - (assert (every #'(lambda (x) - (eq (functional-kind x) :deleted)) - (component-new-functions component))) + (aver (every (lambda (x) + (eq (functional-kind x) :deleted)) + (component-new-functions component))) (setf (component-new-functions component) ()) (dolist (fun (component-lambdas component)) (reinit-lambda-environment fun)) @@ -50,7 +50,7 @@ (let ((kind (functional-kind fun))) (unless (or (eq kind :top-level) (and *byte-compiling* (eq kind :optional))) - (assert (member kind '(:optional :cleanup :escape))) + (aver (member kind '(:optional :cleanup :escape))) (setf (functional-kind fun) nil) (delete-functional fun))))) @@ -219,13 +219,13 @@ (if (find-nlx-info entry cont) (let ((block (node-block exit))) - (assert (= (length (block-succ block)) 1)) + (aver (= (length (block-succ block)) 1)) (unlink-blocks block (first (block-succ block))) (link-blocks block (component-tail (block-component block)))) (insert-nlx-entry-stub exit env)) (let ((info (find-nlx-info entry cont))) - (assert info) + (aver info) (close-over info (node-environment exit) env) (when (eq (functional-kind exit-fun) :escape) (mapc #'(lambda (x) @@ -295,7 +295,7 @@ (code `(%lexical-exit-breakup ',nlx))))))) (when (code) - (assert (not (node-tail-p (block-last block1)))) + (aver (not (node-tail-p (block-last block1)))) (insert-cleanup-code block1 block2 (block-last block1) `(progn ,@(code))) diff --git a/src/compiler/eval-comp.lisp b/src/compiler/eval-comp.lisp index 7e7fa0f..825d2d0 100644 --- a/src/compiler/eval-comp.lisp +++ b/src/compiler/eval-comp.lisp @@ -177,12 +177,12 @@ ((and leaf (typep leaf 'clambda) (member (functional-kind leaf) non-closed-function-kinds)) - (assert (not (eq (functional-kind leaf) :escape))) + (aver (not (eq (functional-kind leaf) :escape))) :unused) (t (typecase dest - ;; Change locations in eval.lisp that think :RETURN - ;; could occur. + ;; Change locations in eval.lisp that think + ;; :RETURN could occur. ((or mv-combination creturn exit) :multiple) (null :unused) (t :single)))))))) diff --git a/src/compiler/eval.lisp b/src/compiler/eval.lisp index 183bd29..0c8ee1d 100644 --- a/src/compiler/eval.lisp +++ b/src/compiler/eval.lisp @@ -497,7 +497,7 @@ ;; within an XEP, so the lambda has an extra arg. (more-args (nthcdr fixed-arg-count args))) (maybe-trace-funny-fun node ,name fixed-arg-count) - (assert (eq (sb!c::continuation-info cont) :multiple)) + (aver (eq (sb!c::continuation-info cont) :multiple)) (eval-stack-push (list more-args (length more-args))))) (sb!c::%unknown-values (error "SB!C::%UNKNOWN-VALUES should never be in interpreter's IR1.")) @@ -561,10 +561,10 @@ ,@letp-bind) ,local-branch)) ((eq (sb!c::continuation-info ,fun) :unused) - (assert (typep ,kind 'sb!c::function-info)) + (aver (typep ,kind 'sb!c::function-info)) (do-funny-function (sb!c::continuation-function-name ,fun))) (t - (assert (typep ,kind 'sb!c::function-info)) + (aver (typep ,kind 'sb!c::function-info)) (do-combination :full nil ,type)))))) (defun trace-eval (on) @@ -607,7 +607,7 @@ (return-from ,function ,value)) ((member ,info '(:multiple :return) :test #'eq) (eval-stack-push (list ,value))) - (t (assert (eq ,info :single)) + (t (aver (eq ,info :single)) (eval-stack-push ,value)))) (defun maybe-trace-nodes (node) @@ -776,10 +776,10 @@ (sb!c::lambda-info lambda))))))) (ecase (sb!c::continuation-info cont) (:single - (assert incoming-values) + (aver incoming-values) (eval-stack-push (car values))) ((:multiple :return) - (assert incoming-values) + (aver incoming-values) (eval-stack-push values)) (:unused))) (t @@ -1088,14 +1088,15 @@ (make-indirect-value-cell (pop args)) (pop args))))))) -;;; This is similar to STORE-LET-VARS, but the values for the locals appear on -;;; the stack in a list due to forms that delivered multiple values to this -;;; lambda/let. Unlike STORE-LET-VARS, there is no control over the delivery -;;; of a value for an unreferenced var, so we drop the corresponding value on -;;; the floor when no one references it. INTERNAL-APPLY uses this for -;;; sb!c::mv-combination nodes representing LET's. +;;; This is similar to STORE-LET-VARS, but the values for the locals +;;; appear on the stack in a list due to forms that delivered multiple +;;; values to this lambda/let. Unlike STORE-LET-VARS, there is no +;;; control over the delivery of a value for an unreferenced var, so +;;; we drop the corresponding value on the floor when no one +;;; references it. INTERNAL-APPLY uses this for sb!c::mv-combination +;;; nodes representing LET's. (defun store-mv-let-vars (lambda frame-ptr count) - (assert (= count 1)) + (aver (= count 1)) (let ((args (eval-stack-pop))) (dolist (v (sb!c::lambda-vars lambda)) (if (sb!c::leaf-refs v) @@ -1119,7 +1120,7 @@ ;;; the recursion. You must do this instead of NREVERSE'ing the args list, so ;;; when we run out of values, we store nil's in the correct lambda-vars. (defun store-mv-let-vars (lambda frame-ptr count) - (assert (= count 1)) + (aver (= count 1)) (print (sb!c::lambda-vars lambda)) (store-mv-let-vars-aux frame-ptr (sb!c::lambda-vars lambda) (eval-stack-pop))) (defun store-mv-let-vars-aux (frame-ptr vars args) diff --git a/src/compiler/generic/core.lisp b/src/compiler/generic/core.lisp index 70e7dd3..3adbc7e 100644 --- a/src/compiler/generic/core.lisp +++ b/src/compiler/generic/core.lisp @@ -52,16 +52,16 @@ (offset (third info)) (value (ecase flavor (:assembly-routine - (assert (symbolp name)) + (aver (symbolp name)) (or (gethash name *assembler-routines*) (error "undefined assembler routine: ~S" name))) (:foreign - (assert (stringp name)) + (aver (stringp name)) (or (sb!impl::foreign-symbol-address-as-integer name) (error "unknown foreign symbol: ~S"))) #!+x86 (:code-object - (assert (null name)) + (aver (null name)) (values (get-lisp-obj-address code) t))))) (sb!vm:fixup-code-object code offset value kind)))) @@ -91,7 +91,7 @@ ;;; references to functions. (defun fix-core-source-info (info object source-info) (declare (type source-info info) (type core-object object)) - (assert (zerop (hash-table-count (core-object-patch-table object)))) + (aver (zerop (hash-table-count (core-object-patch-table object)))) (let ((res (debug-source-for-info info))) (dolist (sinfo res) (setf (debug-source-info sinfo) source-info)) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 77c0160..b5d6fe6 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -375,8 +375,8 @@ (defun maybe-byte-swap (word) (declare (type (unsigned-byte 32) word)) - (assert (= sb!vm:word-bits 32)) - (assert (= sb!vm:byte-bits 8)) + (aver (= sb!vm:word-bits 32)) + (aver (= sb!vm:byte-bits 8)) (if (not *genesis-byte-order-swap-p*) word (logior (ash (ldb (byte 8 0) word) 24) @@ -386,8 +386,8 @@ (defun maybe-byte-swap-short (short) (declare (type (unsigned-byte 16) short)) - (assert (= sb!vm:word-bits 32)) - (assert (= sb!vm:byte-bits 8)) + (aver (= sb!vm:word-bits 32)) + (aver (= sb!vm:byte-bits 8)) (if (not *genesis-byte-order-swap-p*) short (logior (ash (ldb (byte 8 0) short) 8) @@ -395,8 +395,8 @@ ;;; like SAP-REF-32, except that instead of a SAP we use a byte vector (defun byte-vector-ref-32 (byte-vector byte-index) - (assert (= sb!vm:word-bits 32)) - (assert (= sb!vm:byte-bits 8)) + (aver (= sb!vm:word-bits 32)) + (aver (= sb!vm:byte-bits 8)) (ecase sb!c:*backend-byte-order* (:little-endian (logior (ash (aref byte-vector (+ byte-index 0)) 0) @@ -406,8 +406,8 @@ (:big-endian (error "stub: no big-endian ports of SBCL (yet?)")))) (defun (setf byte-vector-ref-32) (new-value byte-vector byte-index) - (assert (= sb!vm:word-bits 32)) - (assert (= sb!vm:byte-bits 8)) + (aver (= sb!vm:word-bits 32)) + (aver (= sb!vm:byte-bits 8)) (ecase sb!c:*backend-byte-order* (:little-endian (setf (aref byte-vector (+ byte-index 0)) (ldb (byte 8 0) new-value) @@ -1557,7 +1557,7 @@ (#.sb!c:pmax-fasl-file-implementation (ecase kind (:jump - (assert (zerop (ash value -28))) + (aver (zerop (ash value -28))) (setf (ldb (byte 26 0) (sap-ref-32 sap 0)) (ash value -2))) (:lui @@ -1613,9 +1613,9 @@ gspace-byte-offset)) (code-object-start-addr (logandc2 (descriptor-bits code-object) sb!vm:lowtag-mask))) - (assert (= code-object-start-addr - (+ gspace-byte-address - (descriptor-byte-offset code-object)))) + (aver (= code-object-start-addr + (+ gspace-byte-address + (descriptor-byte-offset code-object)))) (ecase kind (:absolute (let ((fixed-up (+ value un-fixed-up))) @@ -1663,7 +1663,7 @@ (logand inst #xffffc000))) (:load-short (let ((low-bits (ldb (byte 11 0) value))) - (assert (<= 0 low-bits (1- (ash 1 4)))) + (aver (<= 0 low-bits (1- (ash 1 4)))) (logior (ash low-bits 17) (logand inst #xffe0ffff)))) (:hi @@ -1675,13 +1675,13 @@ (logand inst #xffe00000))) (:branch (let ((bits (ldb (byte 9 2) value))) - (assert (zerop (ldb (byte 2 0) value))) + (aver (zerop (ldb (byte 2 0) value))) (logior (ash bits 3) (logand inst #xffe0e002))))))))) (#.sb!c:alpha-fasl-file-implementation (ecase kind (:jmp-hint - (assert (zerop (ldb (byte 2 0) value))) + (aver (zerop (ldb (byte 2 0) value))) #+nil (setf (sap-ref-16 sap 0) (logior (sap-ref-16 sap 0) (ldb (byte 14 0) (ash value -2))))) @@ -1706,7 +1706,7 @@ (#.sb!c:sgi-fasl-file-implementation (ecase kind (:jump - (assert (zerop (ash value -28))) + (aver (zerop (ash value -28))) (setf (ldb (byte 26 0) (sap-ref-32 sap 0)) (ash value -2))) (:lui @@ -1860,7 +1860,7 @@ (declare (type index old-length)) (declare (type fixnum old-depthoid)) (declare (type list old-inherits-list)) - (assert (eq name old-name)) + (aver (eq name old-name)) (let ((length (descriptor-fixnum length-des)) (inherits-list (listify-cold-inherits cold-inherits)) (depthoid (descriptor-fixnum depthoid-des))) @@ -2849,7 +2849,7 @@ initially undefined function references:~2%") ;; less expensively (ERROR, not CERROR), and which reports ;; "internal error" on failure. Use it here and elsewhere in the ;; system. - (assert (zerop rem)) + (aver (zerop rem)) (write-long floor)) (write-long pages) diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index 2bd2a49..ae2c7cd 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -241,7 +241,7 @@ ;;; (For an explanation of this, see the comments at the definition of ;;; KLUDGE-NONDETERMINISTIC-CATCH-BLOCK-SIZE.) -(assert (= sb!vm::kludge-nondeterministic-catch-block-size catch-block-size)) +(aver (= sb!vm::kludge-nondeterministic-catch-block-size catch-block-size)) ;;;; symbols diff --git a/src/compiler/generic/target-core.lisp b/src/compiler/generic/target-core.lisp index 6a22302..7cfa60d 100644 --- a/src/compiler/generic/target-core.lisp +++ b/src/compiler/generic/target-core.lisp @@ -157,7 +157,7 @@ (load-type-predicate (type-specifier (cdr const)))))) (:xep (let ((xep (cdr (assoc (cdr const) xeps :test #'eq)))) - (assert xep) + (aver xep) (setf (code-header-ref code-obj code-obj-index) xep)))))))))) (values)) diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp index 247e09b..3d98347 100644 --- a/src/compiler/generic/vm-ir2tran.lisp +++ b/src/compiler/generic/vm-ir2tran.lisp @@ -46,7 +46,7 @@ (vop set-slot node block result (ecase kind (:arg - (assert args) + (aver args) (continuation-tn node block (pop args))) (:unbound (or unbound-marker-tn @@ -59,7 +59,7 @@ (:null (emit-constant nil))) name slot lowtag #!+gengc nil)))) - (assert (null args))) + (aver (null args))) (defun do-fixed-alloc (node block name words type lowtag result) #!-gengc @@ -129,7 +129,7 @@ (clambda (environment-closure (get-lambda-environment leaf))) (functional - (assert (eq (functional-kind leaf) :top-level-xep)) + (aver (eq (functional-kind leaf) :top-level-xep)) nil)))) (if closure (let ((this-env (node-environment node))) @@ -180,7 +180,7 @@ (global-var (ecase (global-var-kind leaf) ((:special :global) - (assert (symbolp (leaf-name leaf))) + (aver (symbolp (leaf-name leaf))) (vop set node block (emit-constant (leaf-name leaf)) val-tn (needs-remembering value)))))) diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index f99f6e6..844bfa9 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -637,7 +637,7 @@ (setf (svref table probe) name) (setf (aref index probe) entries-idx) (return)) - (assert (not (equal entry name)))))) + (aver (not (equal entry name)))))) (unless (zerop entries-idx) (setf (aref entries-info (1- entries-idx)) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 30a6a06..27fdf2e 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -29,7 +29,7 @@ ;;; constant node. (declaim (ftype (function (continuation) t) continuation-value)) (defun continuation-value (cont) - (assert (constant-continuation-p cont)) + (aver (constant-continuation-p cont)) (constant-value (ref-leaf (continuation-use cont)))) ;;;; interface for obtaining results of type inference @@ -254,11 +254,11 @@ (return))) (when (and (block-reoptimize block) (block-component block)) - (assert (not (block-delete-p block))) + (aver (not (block-delete-p block))) (ir1-optimize-block block)) (when (and (block-flush-p block) (block-component block)) - (assert (not (block-delete-p block))) + (aver (not (block-delete-p block))) (flush-dead-code block))))) (values)) @@ -465,8 +465,8 @@ (do-uses (use result) (cond ((and (basic-combination-p use) (eq (basic-combination-kind use) :local)) - (assert (eq (lambda-tail-set (node-home-lambda use)) - (lambda-tail-set (combination-lambda use)))) + (aver (eq (lambda-tail-set (node-home-lambda use)) + (lambda-tail-set (combination-lambda use)))) (when (combination-p use) (when (nth-value 1 (maybe-convert-tail-local-call use)) (return-from find-result-type (values))))) @@ -737,8 +737,8 @@ (delete-continuation-use call) (cond ((block-last block) - (assert (and (eq (block-last block) call) - (eq (continuation-kind cont) :block-start)))) + (aver (and (eq (block-last block) call) + (eq (continuation-kind cont) :block-start)))) (t (setf (block-last block) call) (link-blocks block (continuation-starts-block cont))))) @@ -751,7 +751,7 @@ (unlink-blocks block (first (block-succ block))) (setf (component-reanalyze (block-component block)) t) - (assert (not (block-succ block))) + (aver (not (block-succ block))) (link-blocks block tail) (add-continuation-use call (make-continuation)) t)))) @@ -834,9 +834,9 @@ (defun validate-call-type (call type ir1-p) (declare (type combination call) (type ctype type)) (cond ((not (function-type-p type)) - (assert (multiple-value-bind (val win) - (csubtypep type (specifier-type 'function)) - (or val (not win)))) + (aver (multiple-value-bind (val win) + (csubtypep type (specifier-type 'function)) + (or val (not win)))) (recognize-known-call call ir1-p)) ((valid-function-use call type :argument-test #'always-subtypep @@ -1139,8 +1139,8 @@ *empty-type*)) (eq (lexenv-policy (node-lexenv dest)) (lexenv-policy (node-lexenv (continuation-dest arg))))) - (assert (member (continuation-kind arg) - '(:block-start :deleted-block-start :inside-block))) + (aver (member (continuation-kind arg) + '(:block-start :deleted-block-start :inside-block))) (assert-continuation-type arg cont-atype) (setf (node-derived-type ref) *wild-type*) (change-ref-leaf ref (find-constant nil)) @@ -1154,7 +1154,7 @@ ;;; flush the FUN continuation. (defun delete-let (fun) (declare (type clambda fun)) - (assert (member (functional-kind fun) '(:let :mv-let))) + (aver (member (functional-kind fun) '(:let :mv-let))) (note-unreferenced-vars fun) (let ((call (let-combination fun))) (flush-dest (basic-combination-fun call)) @@ -1208,8 +1208,8 @@ this-comp) t) (t - (assert (eq (functional-kind (lambda-home fun)) - :top-level)) + (aver (eq (functional-kind (lambda-home fun)) + :top-level)) nil))) leaf var)) t))))) @@ -1416,9 +1416,9 @@ (declare (ignore ,ignore)) (funcall ,(ref-leaf ref) ,@dums))))) (change-ref-leaf ref fun) - (assert (eq (basic-combination-kind node) :full)) + (aver (eq (basic-combination-kind node) :full)) (local-call-analyze *current-component*) - (assert (eq (basic-combination-kind node) :local))))))))) + (aver (eq (basic-combination-kind node) :local))))))))) (values)) ;;; If we see: diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 6d578ad..4461b9b 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -93,7 +93,8 @@ (slot (find accessor (dd-slots info) :key #'sb!kernel:dsd-accessor)) (type (dd-name info)) (slot-type (dsd-type slot))) - (assert slot () "Can't find slot ~S." type) + (unless slot + (error "can't find slot ~S" type)) (make-slot-accessor :name name :type (specifier-type @@ -155,7 +156,7 @@ (let ((var (lexenv-find name functions :test #'equal))) (cond (var (unless (leaf-p var) - (assert (and (consp var) (eq (car var) 'macro))) + (aver (and (consp var) (eq (car var) 'macro))) (compiler-error "found macro name ~S ~A" name context)) var) (t @@ -276,7 +277,7 @@ #!-sb-fluid (declaim (inline prev-link)) (defun prev-link (node cont) (declare (type node node) (type continuation cont)) - (assert (not (continuation-next cont))) + (aver (not (continuation-next cont))) (setf (continuation-next cont) node) (setf (node-prev node) cont)) @@ -307,15 +308,15 @@ (declare (type node node) (type continuation cont) (inline member)) (let ((block (continuation-block cont)) (node-block (continuation-block (node-prev node)))) - (assert (eq (continuation-kind cont) :block-start)) - (assert (not (block-last node-block)) () "~S has already ended." - node-block) + (aver (eq (continuation-kind cont) :block-start)) + (when (block-last node-block) + (error "~S has already ended." node-block)) (setf (block-last node-block) node) - (assert (null (block-succ node-block)) () "~S already has successors." - node-block) + (when (block-succ node-block) + (error "~S already has successors." node-block)) (setf (block-succ node-block) (list block)) - (assert (not (member node-block (block-pred block) :test #'eq)) () - "~S is already a predecessor of ~S." node-block block) + (when (memq node-block (block-pred block)) + (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*) @@ -465,8 +466,8 @@ (global-var (ir1-convert-srctran start cont lexical-def form)) (t - (assert (and (consp lexical-def) - (eq (car lexical-def) 'macro))) + (aver (and (consp lexical-def) + (eq (car lexical-def) 'macro))) (ir1-convert start cont (careful-expand-macro (cdr lexical-def) form)))))) @@ -541,7 +542,7 @@ (compiler-style-warning "reading an ignored variable: ~S" name)) (reference-leaf start cont var)) (cons - (assert (eq (car var) 'MACRO)) + (aver (eq (car var) 'MACRO)) (ir1-convert start cont (cdr var))) (heap-alien-info (ir1-convert start cont `(%heap-alien ',var))))) @@ -832,7 +833,7 @@ (restr (cons var int)))))) (cons ;; FIXME: non-ANSI weirdness - (assert (eq (car var) 'MACRO)) + (aver (eq (car var) 'MACRO)) (new-vars `(,var-name . (MACRO . (the ,(first decl) ,(cdr var)))))) (heap-alien-info @@ -881,7 +882,7 @@ (let ((var (find-in-bindings vars name))) (etypecase var (cons - (assert (eq (car var) 'MACRO)) + (aver (eq (car var) 'MACRO)) (compiler-error "~S is a symbol-macro and thus can't be declared special." name)) @@ -2650,7 +2651,7 @@ name)) (set-variable start cont leaf (second things))) (cons - (assert (eq (car leaf) 'MACRO)) + (aver (eq (car leaf) 'MACRO)) (ir1-convert start cont `(setf ,(cdr leaf) ,(second things)))) (heap-alien-info (ir1-convert start cont @@ -2729,7 +2730,7 @@ ;;; referencing it. (def-ir1-translator %cleanup-function ((name) start cont) (let ((fun (lexenv-find name functions))) - (assert (lambda-p fun)) + (aver (lambda-p fun)) (setf (functional-kind fun) :cleanup) (reference-leaf start cont fun))) @@ -2869,7 +2870,7 @@ (dolist (pred (block-pred end-block)) (unlink-blocks pred end-block) (link-blocks pred cont-block)) - (assert (not (continuation-dest dummy-result))) + (aver (not (continuation-dest dummy-result))) (delete-continuation dummy-result) (remove-from-dfo end-block)))) @@ -2912,8 +2913,8 @@ ;; QDEF should be a sharp-quoted definition. We don't want to make a ;; function of it just yet, so we just drop the sharp-quote. (def (progn - (assert (eq 'function (first qdef))) - (assert (proper-list-of-length-p qdef 2)) + (aver (eq 'function (first qdef))) + (aver (proper-list-of-length-p qdef 2)) (second qdef)))) (unless (symbolp name) @@ -3034,10 +3035,10 @@ (when (eq x (assoc name variables :test #'eq)) (typecase what (cons - (assert (eq (car what) 'macro)) + (aver (eq (car what) 'macro)) (push x symmacs)) (global-var - (assert (eq (global-var-kind what) :special)) + (aver (eq (global-var-kind what) :special)) (push `(special ,name) decls)) (t (return t)))))) nil) @@ -3072,7 +3073,7 @@ (found (find-free-function name "Eh?"))) (note-name-defined name :function) (cond ((not (defined-function-p found)) - (assert (not (info :function :inlinep name))) + (aver (not (info :function :inlinep name))) (let* ((where-from (leaf-where-from found)) (res (make-defined-function :name name diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index aaaa676..ab01bce 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -96,14 +96,14 @@ ;;; has changed. (declaim (ftype (function (node continuation) (values)) add-continuation-use)) (defun add-continuation-use (node cont) - (assert (not (node-cont node))) + (aver (not (node-cont node))) (let ((block (continuation-block cont))) (ecase (continuation-kind cont) (:deleted) (:unused - (assert (not block)) + (aver (not block)) (let ((block (node-block node))) - (assert block) + (aver block) (setf (continuation-block cont) block)) (setf (continuation-kind cont) :inside-block) (setf (continuation-use cont) node)) @@ -135,7 +135,7 @@ ;;; potential optimization opportunities. (defun substitute-continuation (new old) (declare (type continuation old new)) - (assert (not (continuation-dest new))) + (aver (not (continuation-dest new))) (let ((dest (continuation-dest old))) (etypecase dest ((or ref bind)) @@ -187,7 +187,7 @@ (declare (type continuation cont)) (ecase (continuation-kind cont) (:unused - (assert (not (continuation-block cont))) + (aver (not (continuation-block cont))) (let* ((head (component-head *current-component*)) (next (block-next head)) (new-block (make-block cont))) @@ -367,7 +367,7 @@ (defun %link-blocks (block1 block2) (declare (type cblock block1 block2) (inline member)) (let ((succ1 (block-succ block1))) - (assert (not (member block2 succ1 :test #'eq))) + (aver (not (member block2 succ1 :test #'eq))) (cons block2 succ1))) ;;; Like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2. If this leaves a @@ -383,7 +383,7 @@ (prev succ1 succ)) ((eq (car succ) block2) (setf (cdr prev) (cdr succ))) - (assert succ)))) + (aver succ)))) (let ((new-pred (delq block1 (block-pred block2)))) (setf (block-pred block2) new-pred) @@ -444,7 +444,7 @@ (declare (type cblock block after)) (let ((next (block-next after)) (comp (block-component after))) - (assert (not (eq (component-kind comp) :deleted))) + (aver (not (eq (component-kind comp) :deleted))) (setf (block-component block) comp) (setf (block-next after) block) (setf (block-prev block) after) @@ -488,7 +488,7 @@ (last (block-last block)) (last-cont (node-cont last))) (unless (eq last node) - (assert (and (eq (continuation-kind start) :inside-block) + (aver (and (eq (continuation-kind start) :inside-block) (not (block-delete-p block)))) (let* ((succ (block-succ block)) (new-block @@ -571,8 +571,8 @@ ;;; be called on functions that never had any references, since otherwise ;;; DELETE-REF will handle the deletion. (defun delete-functional (fun) - (assert (and (null (leaf-refs fun)) - (not (functional-entry-function fun)))) + (aver (and (null (leaf-refs fun)) + (not (functional-entry-function fun)))) (etypecase fun (optional-dispatch (delete-optional-dispatch fun)) (clambda (delete-lambda fun))) @@ -597,7 +597,7 @@ (declare (type clambda leaf)) (let ((kind (functional-kind leaf)) (bind (lambda-bind leaf))) - (assert (not (member kind '(:deleted :optional :top-level)))) + (aver (not (member kind '(:deleted :optional :top-level)))) (setf (functional-kind leaf) :deleted) (setf (lambda-bind leaf) nil) (dolist (let (lambda-lets leaf)) @@ -610,7 +610,7 @@ (let* ((bind-block (node-block bind)) (component (block-component bind-block)) (return (lambda-return leaf))) - (assert (null (leaf-refs leaf))) + (aver (null (leaf-refs leaf))) (unless (leaf-ever-used leaf) (let ((*compiler-error-context* bind)) (compiler-note "deleting unused function~:[.~;~:*~% ~S~]" @@ -655,12 +655,12 @@ (declare (type optional-dispatch leaf)) (let ((entry (functional-entry-function leaf))) (unless (and entry (leaf-refs entry)) - (assert (or (not entry) (eq (functional-kind entry) :deleted))) + (aver (or (not entry) (eq (functional-kind entry) :deleted))) (setf (functional-kind leaf) :deleted) (flet ((frob (fun) (unless (eq (functional-kind fun) :deleted) - (assert (eq (functional-kind fun) :optional)) + (aver (eq (functional-kind fun) :optional)) (setf (functional-kind fun) nil) (let ((refs (leaf-refs fun))) (cond ((null refs) @@ -696,7 +696,7 @@ (clambda (ecase (functional-kind leaf) ((nil :let :mv-let :assignment :escape :cleanup) - (assert (not (functional-entry-function leaf))) + (aver (not (functional-entry-function leaf))) (delete-lambda leaf)) (:external (delete-lambda leaf)) @@ -730,7 +730,7 @@ (declare (type continuation cont)) (unless (eq (continuation-kind cont) :deleted) - (assert (continuation-dest cont)) + (aver (continuation-dest cont)) (setf (continuation-dest cont) nil) (do-uses (use cont) (let ((prev (node-prev use))) @@ -766,7 +766,7 @@ ;;; people to ignore them, and to cause them to be deleted eventually. (defun delete-continuation (cont) (declare (type continuation cont)) - (assert (not (eq (continuation-kind cont) :deleted))) + (aver (not (eq (continuation-kind cont) :deleted))) (do-uses (use cont) (let ((prev (node-prev use))) @@ -797,16 +797,17 @@ (values)) -;;; This function does what is necessary to eliminate the code in it from -;;; the IR1 representation. This involves unlinking it from its predecessors -;;; and successors and deleting various node-specific semantic information. +;;; This function does what is necessary to eliminate the code in it +;;; from the IR1 representation. This involves unlinking it from its +;;; predecessors and successors and deleting various node-specific +;;; semantic information. ;;; -;;; We mark the Start as has having no next and remove the last node from -;;; its Cont's uses. We also flush the DEST for all continuations whose values -;;; are received by nodes in the block. +;;; We mark the START as has having no next and remove the last node +;;; from its CONT's uses. We also flush the DEST for all continuations +;;; whose values are received by nodes in the block. (defun delete-block (block) (declare (type cblock block)) - (assert (block-component block) () "Block is already deleted.") + (aver (block-component block)) ; else block is already deleted! (note-block-deletion block) (setf (block-delete-p block) t) @@ -847,8 +848,7 @@ (bind (let ((lambda (bind-lambda node))) (unless (eq (functional-kind lambda) :deleted) - (assert (member (functional-kind lambda) - '(:let :mv-let :assignment))) + (aver (member (functional-kind lambda) '(:let :mv-let :assignment))) (delete-lambda lambda)))) (exit (let ((value (exit-value node)) @@ -877,7 +877,7 @@ (defun delete-return (node) (declare (type creturn node)) (let ((fun (return-lambda node))) - (assert (lambda-return fun)) + (aver (lambda-return fun)) (setf (lambda-return fun) nil)) (values)) @@ -989,7 +989,7 @@ (unless (eq (continuation-kind cont) :deleted) (delete-continuation-use node) (when (eq (continuation-kind cont) :unused) - (assert (not (continuation-dest cont))) + (aver (not (continuation-dest cont))) (delete-continuation cont))) (setf (block-type-asserted block) t) @@ -1007,11 +1007,11 @@ (setf (node-prev node) nil) nil) (t - (assert (eq prev-kind :block-start)) - (assert (eq node last)) + (aver (eq prev-kind :block-start)) + (aver (eq node last)) (let* ((succ (block-succ block)) (next (first succ))) - (assert (and succ (null (cdr succ)))) + (aver (and succ (null (cdr succ)))) (cond ((member block succ) (with-ir1-environment node @@ -1024,8 +1024,8 @@ (setf (node-prev node) nil) nil) (t - (assert (eq (block-start-cleanup block) - (block-end-cleanup block))) + (aver (eq (block-start-cleanup block) + (block-end-cleanup block))) (unlink-blocks block next) (dolist (pred (block-pred block)) (change-block-successor pred block next)) @@ -1054,7 +1054,7 @@ ;;; deletion. (defun delete-component (component) (declare (type component component)) - (assert (null (component-new-functions component))) + (aver (null (component-new-functions component))) (setf (component-kind component) :deleted) (do-blocks (block component) (setf (block-delete-p block) t)) @@ -1087,7 +1087,7 @@ (type index num-args)) (let ((outside (continuation-dest cont)) (inside (continuation-use cont))) - (assert (combination-p outside)) + (aver (combination-p outside)) (unless (combination-p inside) (give-up-ir1-transform)) (let ((inside-fun (combination-fun inside))) @@ -1230,7 +1230,7 @@ ;;; Return the COMBINATION node that is the call to the let Fun. (defun let-combination (fun) (declare (type clambda fun)) - (assert (member (functional-kind fun) '(:let :mv-let))) + (aver (member (functional-kind fun) '(:let :mv-let))) (continuation-dest (node-cont (first (leaf-refs fun))))) ;;; Return the initial value continuation for a let variable or NIL if none. @@ -1244,7 +1244,7 @@ #!-sb-fluid (declaim (inline combination-lambda)) (defun combination-lambda (call) (declare (type basic-combination call)) - (assert (eq (basic-combination-kind call) :local)) + (aver (eq (basic-combination-kind call) :local)) (ref-leaf (continuation-use (basic-combination-fun call)))) (defvar *inline-expansion-limit* 200 @@ -1410,7 +1410,7 @@ (current (rest rpath))) (loop (when (atom form) - (assert (null current)) + (aver (null current)) (return)) (let ((head (first form))) (when (symbolp head) @@ -1674,13 +1674,13 @@ (force-output *error-output*) (values)) -;;; Return a string that somehow names the code in Component. We use +;;; Return a string that somehow names the code in COMPONENT. We use ;;; the source path for the bind node for an arbitrary entry point to ;;; find the source context, then return that as a string. (declaim (ftype (function (component) simple-string) find-component-name)) (defun find-component-name (component) (let ((ep (first (block-succ (component-head component))))) - (assert ep () "no entry points?") + (aver ep) ; else no entry points?? (multiple-value-bind (form context) (find-original-source (node-source-path (continuation-next (block-start ep)))) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index e1c85a9..408514f 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -60,10 +60,10 @@ (or (cdr (assoc thing (ir2-environment-environment (environment-info env)))) (etypecase thing (lambda-var - (assert (eq env (lambda-environment (lambda-var-home thing)))) + (aver (eq env (lambda-environment (lambda-var-home thing)))) (leaf-info thing)) (nlx-info - (assert (eq env (block-environment (nlx-info-target thing)))) + (aver (eq env (block-environment (nlx-info-target thing)))) (ir2-nlx-info-home (nlx-info-info thing)))))) ;;; If LEAF already has a constant TN, return that, otherwise make a @@ -120,7 +120,7 @@ (let ((unsafe (policy node (zerop safety)))) (ecase (global-var-kind leaf) ((:special :global :constant) - (assert (symbolp name)) + (aver (symbolp name)) (let ((name-tn (emit-constant name))) (if unsafe (vop fast-symbol-value node block name-tn res) @@ -156,7 +156,7 @@ (clambda (environment-closure (get-lambda-environment leaf))) (functional - (assert (eq (functional-kind leaf) :top-level-xep)) + (aver (eq (functional-kind leaf) :top-level-xep)) nil)))) (cond (closure (let ((this-env (node-environment node))) @@ -195,7 +195,7 @@ (global-var (ecase (global-var-kind leaf) ((:special :global) - (assert (symbolp (leaf-name leaf))) + (aver (symbolp (leaf-name leaf))) (vop set node block (emit-constant (leaf-name leaf)) val))))) (when locs (emit-move node block val (first locs)) @@ -224,14 +224,14 @@ (let ((ref (continuation-use cont))) (leaf-tn (ref-leaf ref) (node-environment ref)))) (:fixed - (assert (= (length (ir2-continuation-locs 2cont)) 1)) + (aver (= (length (ir2-continuation-locs 2cont)) 1)) (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) - (assert (eq check :simple)) + (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. @@ -260,10 +260,10 @@ (type continuation cont) (list ptypes)) (let* ((locs (ir2-continuation-locs (continuation-info cont))) (nlocs (length locs))) - (assert (= nlocs (length ptypes))) + (aver (= nlocs (length ptypes))) (if (eq (continuation-type-check cont) t) (multiple-value-bind (check types) (continuation-check-types cont) - (assert (eq check :simple)) + (aver (eq check :simple)) (let ((ntypes (length types))) (mapcar #'(lambda (from to-type assertion) (let ((temp (make-normal-tn to-type))) @@ -443,7 +443,7 @@ (declare (type node node) (type ir2-block block) (type template template) (type (or tn-ref null) args) (list info-args) (type cif if) (type boolean not-p)) - (assert (= (template-info-arg-count template) (+ (length info-args) 2))) + (aver (= (template-info-arg-count template) (+ (length info-args) 2))) (let ((consequent (if-consequent if)) (alternative (if-alternative if))) (cond ((drop-thru-p if consequent) @@ -536,14 +536,14 @@ (rtypes (template-result-types template))) (multiple-value-bind (args info-args) (reference-arguments call block (combination-args call) template) - (assert (not (template-more-results-type template))) + (aver (not (template-more-results-type template))) (if (eq rtypes :conditional) (ir2-convert-conditional call block template args info-args (continuation-dest cont) nil) (let* ((results (make-template-result-tns call cont template rtypes)) (r-refs (reference-tn-list results t))) - (assert (= (length info-args) - (template-info-arg-count template))) + (aver (= (length info-args) + (template-info-arg-count template))) (if info-args (emit-template call block template args r-refs info-args) (emit-template call block template args r-refs)) @@ -564,9 +564,9 @@ (multiple-value-bind (args info-args) (reference-arguments call block (cddr (combination-args call)) template) - (assert (not (template-more-results-type template))) - (assert (not (eq rtypes :conditional))) - (assert (null info-args)) + (aver (not (template-more-results-type template))) + (aver (not (eq rtypes :conditional))) + (aver (null info-args)) (if info (emit-template call block template args r-refs info) @@ -782,22 +782,22 @@ (let ((2cont (continuation-info cont))) (if (eq (ir2-continuation-kind 2cont) :delayed) (let ((name (continuation-function-name cont t))) - (assert name) + (aver name) (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))) - (assert (and (eq (ir2-continuation-kind 2cont) :fixed) - (= (length locs) 1))) + (aver (and (eq (ir2-continuation-kind 2cont) :fixed) + (= (length locs) 1))) (cond ((eq (tn-primitive-type loc) function-ptype) - (assert (not (eq check t))) + (aver (not (eq check t))) (values loc nil)) (t (let ((temp (make-normal-tn function-ptype))) - (assert (and (eq (ir2-continuation-primitive-type 2cont) - function-ptype) - (eq check t))) + (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)))))))) @@ -969,7 +969,7 @@ (when (consp fname) (destructuring-bind (setf stem) fname - (assert (eq setf 'setf)) + (aver (eq setf 'setf)) (setf (gethash stem *setf-assumed-fboundp*) t))))) ;;; If the call is in a tail recursive position and the return @@ -1050,8 +1050,8 @@ (declare (type bind node) (type ir2-block block)) (let* ((fun (bind-lambda node)) (env (environment-info (lambda-environment fun)))) - (assert (member (functional-kind fun) - '(nil :external :optional :top-level :cleanup))) + (aver (member (functional-kind fun) + '(nil :external :optional :top-level :cleanup))) (when (external-entry-point-p fun) (init-xep-environment node block fun) @@ -1113,7 +1113,7 @@ (nil) nvals)))) (t - (assert (eq cont-kind :unknown)) + (aver (eq cont-kind :unknown)) (vop* return-multiple node block (old-fp return-pc (reference-tn-list (ir2-continuation-locs 2cont) nil)) @@ -1144,7 +1144,7 @@ (let* ((cont (first (basic-combination-args node))) (fun (ref-leaf (continuation-use (basic-combination-fun node)))) (vars (lambda-vars fun))) - (assert (eq (functional-kind fun) :mv-let)) + (aver (eq (functional-kind fun) :mv-let)) (mapc #'(lambda (src var) (when (leaf-refs var) (let ((dest (leaf-info var))) @@ -1165,7 +1165,7 @@ ;;; contiguous and on stack top. (defun ir2-convert-mv-call (node block) (declare (type mv-combination node) (type ir2-block block)) - (assert (basic-combination-args node)) + (aver (basic-combination-args node)) (let* ((start-cont (continuation-info (first (basic-combination-args node)))) (start (first (ir2-continuation-locs start-cont))) (tails (and (node-tail-p node) @@ -1174,8 +1174,8 @@ (2cont (continuation-info cont))) (multiple-value-bind (fun named) (function-continuation-tn node block (basic-combination-fun node)) - (assert (and (not named) - (eq (ir2-continuation-kind start-cont) :unknown))) + (aver (and (not named) + (eq (ir2-continuation-kind start-cont) :unknown))) (cond (tails (let ((env (environment-info (node-environment node)))) @@ -1197,7 +1197,7 @@ ;;; top of it.) (defoptimizer (%pop-values ir2-convert) ((continuation) node block) (let ((2cont (continuation-info (continuation-value continuation)))) - (assert (eq (ir2-continuation-kind 2cont) :unknown)) + (aver (eq (ir2-continuation-kind 2cont) :unknown)) (vop reset-stack-pointer node block (first (ir2-continuation-locs 2cont))))) @@ -1541,7 +1541,7 @@ (last (block-last block)) (succ (block-succ block))) (unless (if-p last) - (assert (and succ (null (rest succ)))) + (aver (and succ (null (rest succ)))) (let ((target (first succ))) (cond ((eq target (component-tail (block-component block))) (when (and (basic-combination-p last) @@ -1557,7 +1557,7 @@ (emit-constant name) (multiple-value-bind (tn named) (function-continuation-tn last 2block fun) - (assert (not named)) + (aver (not named)) tn))))))) ((not (eq (ir2-block-next 2block) (block-info target))) (vop branch last 2block (block-label target))))))) diff --git a/src/compiler/life.lisp b/src/compiler/life.lisp index 1034aca..cd04213 100644 --- a/src/compiler/life.lisp +++ b/src/compiler/life.lisp @@ -223,8 +223,8 @@ ((null conf) (setf (ir2-block-global-tns block) nil)) (let ((tn (global-conflicts-tn conf))) - (assert (eq (tn-current-conflict tn) conf)) - (assert (null (global-conflicts-tn-next conf))) + (aver (eq (tn-current-conflict tn) conf)) + (aver (null (global-conflicts-tn-next conf))) (do ((current (tn-global-conflicts tn) (global-conflicts-tn-next current)) (prev nil current)) @@ -238,7 +238,7 @@ (let ((ltns (ir2-block-local-tns block))) (dotimes (i local-tn-limit) (let ((tn (svref ltns i))) - (assert (not (eq tn :more))) + (aver (not (eq tn :more))) (let ((conf (tn-global-conflicts tn))) (setf (tn-local tn) (if conf @@ -275,7 +275,7 @@ (defun coalesce-more-ltn-numbers (block ops fixed) (declare (type ir2-block block) (type (or tn-ref null) ops) (list fixed)) (let ((num (ir2-block-local-tn-count block))) - (assert (< num local-tn-limit)) + (aver (< num local-tn-limit)) (incf (ir2-block-local-tn-count block)) (setf (svref (ir2-block-local-tns block) num) :more) @@ -295,9 +295,9 @@ (return nil))))) (and (frob (tn-reads tn)) (frob (tn-writes tn)))) () "More operand ~S used more than once in its VOP." op) - (assert (not (find-in #'global-conflicts-next tn - (ir2-block-global-tns block) - :key #'global-conflicts-tn))) + (aver (not (find-in #'global-conflicts-next tn + (ir2-block-global-tns block) + :key #'global-conflicts-tn))) (add-global-conflict :read-only tn block num) (setf (tn-local tn) block) @@ -345,12 +345,12 @@ (cond ((vop-next lose) - (assert (not (eq last-lose lose))) + (aver (not (eq last-lose lose))) (let ((new (split-ir2-blocks 2block lose (incf counter)))) - (assert (not (find-local-references new))) + (aver (not (find-local-references new))) (init-global-conflict-kind new))) (t - (assert (not (eq lose coalesced))) + (aver (not (eq lose coalesced))) (setq coalesced lose) (event coalesce-more-ltn-numbers (vop-node lose)) (let ((info (vop-info lose)) @@ -363,7 +363,7 @@ (coalesce-more-ltn-numbers new (vop-results lose) (vop-info-result-types info)) (let ((lose (find-local-references new))) - (assert (not lose))) + (aver (not lose))) (init-global-conflict-kind new)))))))) (values)) @@ -433,9 +433,9 @@ ;;; requires adding :LIVE conflicts to all blocks in TN-ENV. (defun convert-to-environment-tn (tn tn-env) (declare (type tn tn) (type environment tn-env)) - (assert (member (tn-kind tn) '(:normal :debug-environment))) + (aver (member (tn-kind tn) '(:normal :debug-environment))) (when (eq (tn-kind tn) :debug-environment) - (assert (eq (tn-environment tn) tn-env)) + (aver (eq (tn-environment tn) tn-env)) (let ((2env (environment-info tn-env))) (setf (ir2-environment-debug-live-tns 2env) (delete tn (ir2-environment-debug-live-tns 2env))))) @@ -483,7 +483,7 @@ (let* ((tn (global-conflicts-tn conf2)) (tn-conflicts (tn-current-conflict tn)) (number1 (ir2-block-number block1))) - (assert tn-conflicts) + (aver tn-conflicts) (do ((current tn-conflicts (global-conflicts-tn-next current)) (prev nil current)) ((or (null current) @@ -711,7 +711,7 @@ (deletef-in tn-next* live-list tn) (frob-more-tns (deletef-in tn-next* live-list mtn)))) (t - (assert (not (tn-ref-write-p ref))) + (aver (not (tn-ref-write-p ref))) (note-conflicts live-bits live-list tn num) (frob-more-tns (note-conflicts live-bits live-list mtn num)) (setf (sbit live-bits num) 1) @@ -838,21 +838,22 @@ (tn-local-conflicts tn) t)) (t - (assert (and (null (tn-reads tn)) (null (tn-writes tn)))))) + (aver (and (null (tn-reads tn)) (null (tn-writes tn)))))) (values)) ;;; For each :ALIAS TN, destructively merge the conflict info into the ;;; original TN and replace the uses of the alias. ;;; -;;; For any block that uses only the alias TN, just insert that conflict into -;;; the conflicts for the original TN, changing the LTN map to refer to the -;;; original TN. This gives a result indistinguishable from the what there -;;; would have been if the original TN had always been referenced. This leaves -;;; no sign that an alias TN was ever involved. +;;; For any block that uses only the alias TN, just insert that +;;; conflict into the conflicts for the original TN, changing the LTN +;;; map to refer to the original TN. This gives a result +;;; indistinguishable from the what there would have been if the +;;; original TN had always been referenced. This leaves no sign that +;;; an alias TN was ever involved. ;;; -;;; If a block has references to both the alias and the original TN, then we -;;; call MERGE-ALIAS-BLOCK-CONFLICTS to combine the conflicts into the original -;;; conflict. +;;; If a block has references to both the alias and the original TN, +;;; then we call MERGE-ALIAS-BLOCK-CONFLICTS to combine the conflicts +;;; into the original conflict. (defun merge-alias-conflicts (component) (declare (type component component)) (do ((tn (ir2-component-alias-tns (component-info component)) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 2066422..dadfbdd 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -175,7 +175,7 @@ ;;; discover an XEP after the initial local call analyze pass. (defun make-external-entry-point (fun) (declare (type functional fun)) - (assert (not (functional-entry-function fun))) + (aver (not (functional-entry-function fun))) (with-ir1-environment (lambda-bind (main-entry fun)) (let* ((*lexenv* (make-lexenv :policy (make-interface-policy *lexenv*))) (res (ir1-convert-lambda (make-xep-lambda fun)))) @@ -332,7 +332,7 @@ (let* ((block (node-block call)) (component (block-component block)) (original-fun (ref-leaf ref))) - (assert (functional-p original-fun)) + (aver (functional-p original-fun)) (unless (or (member (basic-combination-kind call) '(:local :error)) (block-delete-p block) (eq (functional-kind (block-home-lambda block)) :deleted) @@ -352,8 +352,8 @@ (rest (leaf-refs original-fun))) (setq fun (maybe-expand-local-inline fun ref call))) - (assert (member (functional-kind fun) - '(nil :escape :cleanup :optional))) + (aver (member (functional-kind fun) + '(nil :escape :cleanup :optional))) (cond ((mv-combination-p call) (convert-mv-call ref call fun)) ((lambda-p fun) @@ -636,7 +636,7 @@ (component (block-component call-block))) (let ((fun-component (block-component bind-block))) (unless (eq fun-component component) - (assert (eq (component-kind component) :initial)) + (aver (eq (component-kind component) :initial)) (join-components component fun-component))) (let ((*current-component* component)) @@ -644,7 +644,7 @@ ;; FIXME: Use PROPER-LIST-OF-LENGTH-P here, and look for other ;; uses of '=.*length' which could also be converted to use ;; PROPER-LIST-OF-LENGTH-P. - (assert (= (length (block-succ call-block)) 1)) + (aver (= (length (block-succ call-block)) 1)) (let ((next-block (first (block-succ call-block)))) (unlink-blocks call-block next-block) (link-blocks call-block bind-block) @@ -767,7 +767,7 @@ (add-continuation-use this-call cont))) (:deleted) (:assignment - (assert (eq called fun)))))))) + (aver (eq called fun)))))))) (values)) ;;; Deal with returning from a LET or assignment that we are @@ -806,7 +806,7 @@ (move-return-uses fun call (or next-block (node-block call-return))))) (t - (assert (node-tail-p call)) + (aver (node-tail-p call)) (setf (lambda-return call-fun) return) (setf (return-lambda return) call-fun)))) (move-let-call-cont fun) @@ -922,7 +922,7 @@ (defun maybe-convert-tail-local-call (call) (declare (type combination call)) (let ((return (continuation-dest (node-cont call)))) - (assert (return-p return)) + (aver (return-p return)) (when (and (not (node-tail-p call)) (immediately-used-p (return-result return) call) (not (eq (functional-kind (node-home-lambda call)) diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index 8b1ce48..ba40a14 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -105,7 +105,7 @@ (defun annotate-1-value-continuation (cont) (declare (type continuation cont)) (let ((info (continuation-info cont))) - (assert (eq (ir2-continuation-kind info) :fixed)) + (aver (eq (ir2-continuation-kind info) :fixed)) (cond ((continuation-delayed-leaf cont) (setf (ir2-continuation-kind info) :delayed)) @@ -419,8 +419,8 @@ (defun set-tail-local-call-successor (call) (let ((caller (node-home-lambda call)) (callee (combination-lambda call))) - (assert (eq (lambda-tail-set caller) - (lambda-tail-set (lambda-home callee)))) + (aver (eq (lambda-tail-set caller) + (lambda-tail-set (lambda-home callee)))) (node-ends-block call) (let ((block (node-block call))) (unlink-blocks block (first (block-succ block))) @@ -721,7 +721,7 @@ (funcall frob "This shouldn't happen! Bug?") (multiple-value-bind (win why) (is-ok-template-use template call (ltn-policy-safe-p ltn-policy)) - (assert (not win)) + (aver (not win)) (ecase why (:guard (funcall frob "template guard failed")) @@ -819,11 +819,11 @@ ((and valid strict-valid) (strange-template-failure loser call ltn-policy #'frob)) ((not valid) - (assert (not (valid-function-use call type - :error-function #'frob - :warning-function #'frob)))) + (aver (not (valid-function-use call type + :error-function #'frob + :warning-function #'frob)))) (t - (assert (ltn-policy-safe-p ltn-policy)) + (aver (ltn-policy-safe-p ltn-policy)) (frob "can't trust output type assertion under safe policy"))) (count 1)))) @@ -976,7 +976,7 @@ (declare (type component component)) (let ((2comp (component-info component))) (do-blocks (block component) - (assert (not (block-info block))) + (aver (not (block-info block))) (let ((2block (make-ir2-block block))) (setf (block-info block) 2block) (ltn-analyze-block block) @@ -992,6 +992,6 @@ (defun ltn-analyze-belated-block (block) (declare (type cblock block)) (ltn-analyze-block block) - (assert (not (ir2-block-popped (block-info block)))) + (aver (not (ir2-block-popped (block-info block)))) (values)) diff --git a/src/compiler/ltv.lisp b/src/compiler/ltv.lisp index 6d8e83a..b84c0de 100644 --- a/src/compiler/ltv.lisp +++ b/src/compiler/ltv.lisp @@ -40,7 +40,7 @@ `(value-cell-ref ',(make-value-cell value))))))) (defoptimizer (%load-time-value ir2-convert) ((handle) node block) - (assert (constant-continuation-p handle)) + (aver (constant-continuation-p handle)) (let ((cont (node-cont node)) (tn (make-load-time-value-tn (continuation-value handle) *universal-type*))) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 99325e6..91a013b 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -665,7 +665,7 @@ ,(if restart-p `(cond ((eq (continuation-block ,cont-var) ,n-block) - (assert (continuation-next ,cont-var)) + (aver (continuation-next ,cont-var)) (continuation-next ,cont-var)) (t (let ((start (block-start ,n-block))) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index e70a997..159a033 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -592,8 +592,8 @@ (clrhash *id-labels*) (setq *label-id* 0) - ;; Clear some Pack data structures (for GC purposes only). - (assert (not *in-pack*)) + ;; Clear some PACK data structures (for GC purposes only). + (aver (not *in-pack*)) (dolist (sb *backend-sb-list*) (when (finite-sb-p sb) (fill (finite-sb-live-tns sb) nil)))) @@ -1056,7 +1056,7 @@ ;;; the name. If not in a :TOP-LEVEL component, then don't bother ;;; compiling, because it was merged with a run-time component. (defun compile-load-time-value-lambda (lambdas) - (assert (null (cdr lambdas))) + (aver (null (cdr lambdas))) (let* ((lambda (car lambdas)) (component (block-component (node-block (lambda-bind lambda))))) (when (eq (component-kind component) :top-level) @@ -1114,7 +1114,7 @@ (defvar *constants-created-since-last-init* nil) ;;; FIXME: Shouldn't these^ variables be bound in LET forms? (defun emit-make-load-form (constant) - (assert (fasl-file-p *compile-object*)) + (aver (fasl-file-p *compile-object*)) (unless (or (fasl-constant-already-dumped constant *compile-object*) ;; KLUDGE: This special hack is because I was too lazy ;; to rework DEF!STRUCT so that the MAKE-LOAD-FORM diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp index 8b88ecd..12c594e 100644 --- a/src/compiler/meta-vmdef.lisp +++ b/src/compiler/meta-vmdef.lisp @@ -616,7 +616,7 @@ (declare (type operand-parse temp)) (let ((sc (operand-parse-sc temp)) (offset (operand-parse-offset temp))) - (assert sc) + (aver sc) (setf (aref results index) (if offset (+ (ash offset (1+ sc-bits)) diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp index a001be5..854b974 100644 --- a/src/compiler/pack.lisp +++ b/src/compiler/pack.lisp @@ -133,9 +133,9 @@ (when (ir2-block-number 2block) (return (1+ (ir2-block-number 2block)))))) -;;; Ensure that the conflicts vectors for each :Finite SB are large enough -;;; for the number of blocks allocated. Also clear any old conflicts and reset -;;; the current size to the initial size. +;;; Ensure that the conflicts vectors for each :Finite SB are large +;;; enough for the number of blocks allocated. Also clear any old +;;; conflicts and reset the current size to the initial size. (defun init-sb-vectors (component) (let ((nblocks (ir2-block-count component))) (dolist (sb *backend-sb-list*) @@ -185,9 +185,9 @@ (setf (finite-sb-current-size sb) (sb-size sb)) (setf (finite-sb-last-offset sb) 0)))))) -;;; Expand the :Unbounded SB backing SC by either the initial size or the SC -;;; element size, whichever is larger. If Needed-Size is larger, then use that -;;; size. +;;; Expand the :Unbounded SB backing SC by either the initial size or +;;; the SC element size, whichever is larger. If Needed-Size is +;;; larger, then use that size. (defun grow-sc (sc &optional (needed-size 0)) (declare (type sc sc) (type index needed-size)) (let* ((sb (sc-sb sc)) @@ -204,7 +204,7 @@ (ir2-block-count *component-being-compiled*) (length (the simple-vector (svref conflicts 0)))))) (declare (type index inc new-size)) - (assert (eq (sb-kind sb) :unbounded)) + (aver (eq (sb-kind sb) :unbounded)) (when (> new-size (length conflicts)) (let ((new-conf (make-array new-size))) @@ -244,9 +244,9 @@ (defvar *in-pack* nil) ;;; In order to prevent the conflict data structures from growing -;;; arbitrarily large, we clear them whenever a GC happens and we aren't -;;; currently in pack. We revert to the initial number of locations and 0 -;;; blocks. +;;; arbitrarily large, we clear them whenever a GC happens and we +;;; aren't currently in pack. We revert to the initial number of +;;; locations and 0 blocks. (defun pack-before-gc-hook () (unless *in-pack* (dolist (sb *backend-sb-list*) @@ -303,23 +303,23 @@ (error "loading to/from SCs that aren't alternates?~@ VM definition is inconsistent, try recompiling."))))) -;;; Called when we failed to pack TN. If Restricted is true, then we we -;;; restricted to pack TN in its SC. +;;; Called when we failed to pack TN. If RESTRICTED is true, then we +;;; are restricted to pack TN in its SC. (defun failed-to-pack-error (tn restricted) (declare (type tn tn)) (let* ((sc (tn-sc tn)) (scs (cons sc (sc-alternate-scs sc)))) (cond (restricted - (error "Failed to pack restricted TN ~S in its SC ~S." + (error "failed to pack restricted TN ~S in its SC ~S" tn (sc-name sc))) (t - (assert (not (find :unbounded scs - :key #'(lambda (x) (sb-kind (sc-sb x)))))) + (aver (not (find :unbounded scs + :key #'(lambda (x) (sb-kind (sc-sb x)))))) (let ((ptype (tn-primitive-type tn))) (cond (ptype - (assert (member (sc-number sc) (primitive-type-scs ptype))) + (aver (member (sc-number sc) (primitive-type-scs ptype))) (error "SC ~S doesn't have any :Unbounded alternate SCs, but is~@ a SC for primitive-type ~S." (sc-name sc) (primitive-type-name ptype))) @@ -327,7 +327,8 @@ (error "SC ~S doesn't have any :Unbounded alternate SCs." (sc-name sc))))))))) -;;; Return a list of format arguments describing how TN is used in Op's VOP. +;;; Return a list of format arguments describing how TN is used in +;;; OP's VOP. (defun describe-tn-use (loc tn op) (let* ((vop (tn-ref-vop op)) (args (vop-args vop)) @@ -362,8 +363,8 @@ (t `("~2D: not referenced?" ,loc))))) -;;; If load TN packing fails, try to give a helpful error message. We find -;;; a TN in each location that conflicts, and print it. +;;; If load TN packing fails, try to give a helpful error message. We +;;; find a TN in each location that conflicts, and print it. (defun failed-to-pack-load-tn-error (scs op) (declare (list scs) (type tn-ref op)) (collect ((used) @@ -371,7 +372,7 @@ (dolist (sc scs) (let* ((sb (sc-sb sc)) (confs (finite-sb-live-tns sb))) - (assert (eq (sb-kind sb) :finite)) + (aver (eq (sb-kind sb) :finite)) (dolist (el (sc-locations sc)) (declare (type index el)) (let ((conf (load-tn-conflicts-in-sc op sc el t))) @@ -390,8 +391,8 @@ (multiple-value-bind (arg-p n more-p costs load-scs incon) (get-operand-info op) (declare (ignore costs load-scs)) - (assert (not more-p)) - (error "Unable to pack a Load-TN in SC ~{~A~#[~^~;, or ~:;,~]~} ~ + (aver (not more-p)) + (error "unable to pack a Load-TN in SC ~{~A~#[~^~;, or ~:;,~]~} ~ for the ~:R ~:[result~;argument~] to~@ the ~S VOP,~@ ~:[since all SC elements are in use:~:{~%~@?~}~%~;~ @@ -405,8 +406,8 @@ (unused) (used) incon)))) -;;; Called when none of the SCs that we can load Op into are allowed by Op's -;;; primitive-type. +;;; This is called when none of the SCs that we can load OP into are +;;; allowed by OP's primitive-type. (defun no-load-scs-allowed-by-primitive-type-error (ref) (declare (type tn-ref ref)) (let* ((tn (tn-ref-tn ref)) @@ -414,7 +415,7 @@ (multiple-value-bind (arg-p pos more-p costs load-scs incon) (get-operand-info ref) (declare (ignore costs)) - (assert (not more-p)) + (aver (not more-p)) (error "~S is not valid as the ~:R ~:[result~;argument~] to VOP:~ ~% ~S,~@ since the TN's primitive type ~S doesn't allow any of the SCs~@ @@ -444,7 +445,7 @@ (declare (type tn tn)) (let ((res (make-tn 0 :save nil nil))) (dolist (alt (sc-alternate-scs (tn-sc tn)) - (error "No unbounded alternate for SC ~S." + (error "no unbounded alternate for SC ~S" (sc-name (tn-sc tn)))) (when (eq (sb-kind (sc-sb alt)) :unbounded) (setf (tn-save-tn tn) res) @@ -453,7 +454,7 @@ (pack-tn res t) (return res))))) -;;; Find the load function for moving from Src to Dest and emit a +;;; Find the load function for moving from SRC to DEST and emit a ;;; MOVE-OPERAND VOP with that function as its info arg. (defun emit-operand-load (node block src dest before) (declare (type node node) (type ir2-block block) @@ -467,24 +468,25 @@ before) (values)) -;;; Find the preceding use of the VOP NAME in the emit order, starting with -;;; VOP. We must find the VOP in the same IR1 block. +;;; Find the preceding use of the VOP NAME in the emit order, starting +;;; with VOP. We must find the VOP in the same IR1 block. (defun reverse-find-vop (name vop) (do* ((block (vop-block vop) (ir2-block-prev block)) (last vop (ir2-block-last-vop block))) (nil) - (assert (eq (ir2-block-block block) (ir2-block-block (vop-block vop)))) + (aver (eq (ir2-block-block block) (ir2-block-block (vop-block vop)))) (do ((current last (vop-prev current))) ((null current)) (when (eq (vop-info-name (vop-info current)) name) (return-from reverse-find-vop current))))) -;;; For TNs that have other than one writer, we save the TN before each -;;; call. If a local call (MOVE-ARGS is :LOCAL-CALL), then we scan back for -;;; the ALLOCATE-FRAME VOP, and emit the save there. This is necessary because -;;; in a self-recursive local call, the registers holding the current arguments -;;; may get trashed by setting up the call arguments. The ALLOCATE-FRAME VOP -;;; marks a place at which the values are known to be good. +;;; For TNs that have other than one writer, we save the TN before +;;; each call. If a local call (MOVE-ARGS is :LOCAL-CALL), then we +;;; scan back for the ALLOCATE-FRAME VOP, and emit the save there. +;;; This is necessary because in a self-recursive local call, the +;;; registers holding the current arguments may get trashed by setting +;;; up the call arguments. The ALLOCATE-FRAME VOP marks a place at +;;; which the values are known to be good. (defun save-complex-writer-tn (tn vop) (let ((save (or (tn-save-tn tn) (pack-save-tn tn))) @@ -493,7 +495,7 @@ (next (vop-next vop))) (when (eq (tn-kind save) :specified-save) (setf (tn-kind save) :save)) - (assert (eq (tn-kind save) :save)) + (aver (eq (tn-kind save) :save)) (emit-operand-load node block tn save (if (eq (vop-info-move-args (vop-info vop)) :local-call) @@ -501,16 +503,16 @@ vop)) (emit-operand-load node block save tn next))) -;;; Return a VOP after which is an o.k. place to save the value of TN. For -;;; correctness, it is only required that this location be after any possible -;;; write and before any possible restore location. +;;; Return a VOP after which is an o.k. place to save the value of TN. +;;; For correctness, it is only required that this location be after +;;; any possible write and before any possible restore location. ;;; -;;; In practice, we return the unique writer VOP, but give up if the TN is -;;; ever read by a VOP with MOVE-ARGS :LOCAL-CALL. This prevents us from being -;;; confused by non-tail local calls. +;;; In practice, we return the unique writer VOP, but give up if the +;;; TN is ever read by a VOP with MOVE-ARGS :LOCAL-CALL. This prevents +;;; us from being confused by non-tail local calls. ;;; -;;; When looking for writes, we have to ignore uses of MOVE-OPERAND, since they -;;; will correspond to restores that we have already done. +;;; When looking for writes, we have to ignore uses of MOVE-OPERAND, +;;; since they will correspond to restores that we have already done. (defun find-single-writer (tn) (declare (type tn tn)) (do ((write (tn-writes tn) (tn-ref-next write)) @@ -531,8 +533,8 @@ (when res (return nil)) (setq res write)))) -;;; Try to save TN at a single location. If we succeed, return T, otherwise -;;; NIL. +;;; Try to save TN at a single location. If we succeed, return T, +;;; otherwise NIL. (defun save-single-writer-tn (tn) (declare (type tn tn)) (let* ((old-save (tn-save-tn tn)) @@ -550,7 +552,7 @@ (defun restore-single-writer-tn (tn vop) (declare (type tn) (type vop vop)) (let ((save (tn-save-tn tn))) - (assert (eq (tn-kind save) :save-once)) + (aver (eq (tn-kind save) :save-once)) (emit-operand-load (vop-node vop) (vop-block vop) save tn (vop-next vop))) (values)) @@ -583,24 +585,25 @@ ;;;; optimized saving -;;; Save TN if it isn't a single-writer TN that has already been saved. If -;;; multi-write, we insert the save Before the specified VOP. Context is a VOP -;;; used to tell which node/block to use for the new VOP. +;;; Save TN if it isn't a single-writer TN that has already been +;;; saved. If multi-write, we insert the save Before the specified +;;; VOP. Context is a VOP used to tell which node/block to use for the +;;; new VOP. (defun save-if-necessary (tn before context) (declare (type tn tn) (type (or vop null) before) (type vop context)) (let ((save (tn-save-tn tn))) (when (eq (tn-kind save) :specified-save) (setf (tn-kind save) :save)) - (assert (member (tn-kind save) '(:save :save-once))) + (aver (member (tn-kind save) '(:save :save-once))) (unless (eq (tn-kind save) :save-once) (or (save-single-writer-tn tn) (emit-operand-load (vop-node context) (vop-block context) tn save before)))) (values)) -;;; Load the TN from its save location, allocating one if necessary. The -;;; load is inserted Before the specifier VOP. Context is a VOP used to tell -;;; which node/block to use for the new VOP. +;;; Load the TN from its save location, allocating one if necessary. +;;; The load is inserted Before the specifier VOP. Context is a VOP +;;; used to tell which node/block to use for the new VOP. (defun restore-tn (tn before context) (declare (type tn tn) (type (or vop null) before) (type vop context)) (let ((save (or (tn-save-tn tn) (pack-save-tn tn)))) @@ -622,31 +625,33 @@ ) ; EVAL-WHEN -;;; Start scanning backward at the end of Block, looking which TNs are live -;;; and looking for places where we have to save. We manipulate two sets: -;;; SAVES and RESTORES. +;;; Start scanning backward at the end of BLOCK, looking which TNs are +;;; live and looking for places where we have to save. We manipulate +;;; two sets: SAVES and RESTORES. ;;; -;;; SAVES is a set of all the TNs that have to be saved because they are -;;; restored after some call. We normally delay saving until the beginning of -;;; the block, but we must save immediately if we see a write of the saved TN. -;;; We also immediately save all TNs and exit when we see a -;;; NOTE-ENVIRONMENT-START VOP, since saves can't be done before the -;;; environment is properly initialized. +;;; SAVES is a set of all the TNs that have to be saved because they +;;; are restored after some call. We normally delay saving until the +;;; beginning of the block, but we must save immediately if we see a +;;; write of the saved TN. We also immediately save all TNs and exit +;;; when we see a NOTE-ENVIRONMENT-START VOP, since saves can't be +;;; done before the environment is properly initialized. ;;; -;;; RESTORES is a set of all the TNs read (and not written) between here and -;;; the next call, i.e. the set of TNs that must be restored when we reach the -;;; next (earlier) call VOP. Unlike SAVES, this set is cleared when we do -;;; the restoring after a call. Any TNs that were in RESTORES are moved into -;;; SAVES to ensure that they are saved at some point. +;;; RESTORES is a set of all the TNs read (and not written) between +;;; here and the next call, i.e. the set of TNs that must be restored +;;; when we reach the next (earlier) call VOP. Unlike SAVES, this set +;;; is cleared when we do the restoring after a call. Any TNs that +;;; were in RESTORES are moved into SAVES to ensure that they are +;;; saved at some point. ;;; -;;; SAVES and RESTORES are represented using both a list and a bit-vector so -;;; that we can quickly iterate and test for membership. The incoming Saves -;;; and Restores args are used for computing these sets (the initial contents -;;; are ignored.) +;;; SAVES and RESTORES are represented using both a list and a +;;; bit-vector so that we can quickly iterate and test for membership. +;;; The incoming Saves and Restores args are used for computing these +;;; sets (the initial contents are ignored.) ;;; ;;; When we hit a VOP with :COMPUTE-ONLY Save-P (an internal error -;;; location), we pretend that all live TNs were read, unless (= speed 3), in -;;; which case we mark all the TNs that are live but not restored as spilled. +;;; location), we pretend that all live TNs were read, unless (= speed +;;; 3), in which case we mark all the TNs that are live but not +;;; restored as spilled. (defun optimized-emit-saves-block (block saves restores) (declare (type ir2-block block) (type simple-bit-vector saves restores)) (let ((1block (ir2-block-block block)) @@ -666,7 +671,7 @@ (do ((block block (ir2-block-prev block)) (prev nil block)) ((not (eq (ir2-block-block block) 1block)) - (assert (not skipping)) + (aver (not skipping)) (dolist (save saves-list) (let ((start (ir2-block-start-vop prev))) (save-if-necessary save start start))) @@ -676,10 +681,10 @@ (let ((info (vop-info vop))) (case (vop-info-name info) (allocate-frame - (assert skipping) + (aver skipping) (setq skipping nil)) (note-environment-start - (assert (not skipping)) + (aver (not skipping)) (dolist (save saves-list) (save-if-necessary save (vop-next vop) vop)) (return-from optimized-emit-saves-block block))) @@ -735,10 +740,11 @@ ((null read)) (save-note-read (tn-ref-tn read)))))))))) -;;; Like EMIT-SAVES, only different. We avoid redundant saving within the -;;; block, and don't restore values that aren't used before the next call. -;;; This function is just the top-level loop over the blocks in the component, -;;; which locates blocks that need saving done. +;;; Like EMIT-SAVES, only different. We avoid redundant saving within +;;; the block, and don't restore values that aren't used before the +;;; next call. This function is just the top-level loop over the +;;; blocks in the component, which locates blocks that need saving +;;; done. (defun optimized-emit-saves (component) (declare (type component component)) (let* ((gtn-count (1+ (ir2-component-global-tn-counter @@ -756,10 +762,10 @@ (setq block (optimized-emit-saves-block block saves restores))) (setq block (ir2-block-prev block))))) -;;; Iterate over the normal TNs, finding the cost of packing on the stack in -;;; units of the number of references. We count all references as +1, and -;;; subtract out REGISTER-SAVE-PENALTY for each place where we would have to -;;; save a register. +;;; Iterate over the normal TNs, finding the cost of packing on the +;;; stack in units of the number of references. We count all +;;; references as +1, and subtract out REGISTER-SAVE-PENALTY for each +;;; place where we would have to save a register. (defun assign-tn-costs (component) (do-ir2-blocks (block component) (do ((vop (ir2-block-start-vop block) (vop-next vop))) @@ -783,20 +789,20 @@ ;;;; load TN packing -;;; These variables indicate the last location at which we computed the -;;; Live-TNs. They hold the Block and VOP values that were passed to -;;; Compute-Live-TNs. +;;; These variables indicate the last location at which we computed +;;; the Live-TNs. They hold the Block and VOP values that were passed +;;; to Compute-Live-TNs. (defvar *live-block*) (defvar *live-vop*) -;;; If we unpack some TNs, then we mark all affected blocks by sticking them in -;;; this hash-table. This is initially null. We create the hashtable if we do -;;; any unpacking. +;;; If we unpack some TNs, then we mark all affected blocks by +;;; sticking them in this hash-table. This is initially null. We +;;; create the hashtable if we do any unpacking. (defvar *repack-blocks*) (declaim (type (or hash-table null) *repack-blocks*)) -;;; Set the Live-TNs vectors in all :Finite SBs to represent the TNs live at -;;; the end of Block. +;;; Set the Live-TNs vectors in all :Finite SBs to represent the TNs +;;; live at the end of Block. (defun init-live-tns (block) (dolist (sb *backend-sb-list*) (when (eq (sb-kind sb) :finite) @@ -817,10 +823,11 @@ (values)) -;;; Set the Live-TNs in :Finite SBs to represent the TNs live immediately -;;; after the evaluation of VOP in Block, excluding results of the VOP. If VOP -;;; is null, then compute the live TNs at the beginning of the block. -;;; Sequential calls on the same block must be in reverse VOP order. +;;; Set the Live-TNs in :Finite SBs to represent the TNs live +;;; immediately after the evaluation of VOP in Block, excluding +;;; results of the VOP. If VOP is null, then compute the live TNs at +;;; the beginning of the block. Sequential calls on the same block +;;; must be in reverse VOP order. (defun compute-live-tns (block vop) (declare (type ir2-block block) (type vop vop)) (unless (eq block *live-block*) @@ -851,7 +858,7 @@ (end (+ (tn-offset ltn) (sc-element-size sc)))) ((= offset end)) (declare (type index offset end)) - (assert (null (svref tns offset))))))))) + (aver (null (svref tns offset))))))))) (let* ((tn (tn-ref-tn ref)) (sc (tn-sc tn)) @@ -865,16 +872,16 @@ (if (tn-ref-write-p ref) (setf (svref tns offset) nil) (let ((old (svref tns offset))) - (assert (or (null old) (eq old tn)) (old tn)) + (aver (or (null old) (eq old tn))) (setf (svref tns offset) tn))))))))) (setq *live-vop* vop) (values)) -;;; Kind of like Offset-Conflicts-In-SB, except that it uses the VOP refs to -;;; determine whether a Load-TN for OP could be packed in the specified -;;; location, disregarding conflicts with TNs not referenced by this VOP. -;;; There is a conflict if either: +;;; This is kind of like Offset-Conflicts-In-SB, except that it uses +;;; the VOP refs to determine whether a Load-TN for OP could be packed +;;; in the specified location, disregarding conflicts with TNs not +;;; referenced by this VOP. There is a conflict if either: ;;; 1. The reference is a result, and the same location is either: ;;; -- Used by some other result. ;;; -- Used in any way after the reference (exclusive). @@ -883,21 +890,22 @@ ;;; -- Used in any way before the reference (exclusive). ;;; ;;; In 1 (and 2) above, the first bullet corresponds to result-result -;;; (and argument-argument) conflicts. We need this case because there aren't -;;; any TN-REFs to represent the implicit reading of results or writing of -;;; arguments. +;;; (and argument-argument) conflicts. We need this case because there +;;; aren't any TN-REFs to represent the implicit reading of results or +;;; writing of arguments. ;;; ;;; The second bullet corresponds conflicts with temporaries or between ;;; arguments and results. ;;; -;;; We consider both the TN-REF-TN and the TN-REF-LOAD-TN (if any) to be -;;; referenced simultaneously and in the same way. This causes load-TNs to -;;; appear live to the beginning (or end) of the VOP, as appropriate. +;;; We consider both the TN-REF-TN and the TN-REF-LOAD-TN (if any) to +;;; be referenced simultaneously and in the same way. This causes +;;; load-TNs to appear live to the beginning (or end) of the VOP, as +;;; appropriate. ;;; ;;; We return a conflicting TN if there is a conflict. (defun load-tn-offset-conflicts-in-sb (op sb offset) (declare (type tn-ref op) (type finite-sb sb) (type index offset)) - (assert (eq (sb-kind sb) :finite)) + (aver (eq (sb-kind sb) :finite)) (let ((vop (tn-ref-vop op))) (labels ((tn-overlaps (tn) (let ((sc (tn-sc tn)) @@ -932,11 +940,11 @@ (is-ref (tn-ref-next-ref op) nil)))))) ;;; Iterate over all the elements in the SB that would be allocated by -;;; allocating a TN in SC at Offset, checking for conflict with load-TNs or -;;; other TNs (live in the LIVE-TNS, which must be set up.) We also return -;;; true if there aren't enough locations after Offset to hold a TN in SC. -;;; If Ignore-Live is true, then we ignore the live-TNs, considering only -;;; references within Op's VOP. +;;; allocating a TN in SC at Offset, checking for conflict with +;;; load-TNs or other TNs (live in the LIVE-TNS, which must be set +;;; up.) We also return true if there aren't enough locations after +;;; Offset to hold a TN in SC. If Ignore-Live is true, then we ignore +;;; the live-TNs, considering only references within Op's VOP. ;;; ;;; We return a conflicting TN, or :OVERFLOW if the TN won't fit. (defun load-tn-conflicts-in-sc (op sc offset ignore-live) @@ -952,16 +960,18 @@ (load-tn-offset-conflicts-in-sb op sb i)))) (when res (return res)))))) -;;; If a load-TN for Op is targeted to a legal location in SC, then return -;;; the offset, otherwise return NIL. We see whether the target of the -;;; operand is packed, and try that location. There isn't any need to chain -;;; down the target path, since everything is packed now. +;;; If a load-TN for Op is targeted to a legal location in SC, then +;;; return the offset, otherwise return NIL. We see whether the target +;;; of the operand is packed, and try that location. There isn't any +;;; need to chain down the target path, since everything is packed +;;; now. ;;; -;;; We require the target to be in SC (and not merely to overlap with SC). -;;; This prevents SC information from being lost in load TNs (we won't pack a -;;; load TN in ANY-REG when it is targeted to a DESCRIPTOR-REG.) This -;;; shouldn't hurt the code as long as all relevant overlapping SCs are allowed -;;; in the operand SC restriction. +;;; We require the target to be in SC (and not merely to overlap with +;;; SC). This prevents SC information from being lost in load TNs (we +;;; won't pack a load TN in ANY-REG when it is targeted to a +;;; DESCRIPTOR-REG.) This shouldn't hurt the code as long as all +;;; relevant overlapping SCs are allowed in the operand SC +;;; restriction. (defun find-load-tn-target (op sc) (declare (inline member)) (let ((target (tn-ref-target op))) @@ -974,8 +984,9 @@ loc nil))))) -;;; Select a legal location for a load TN for Op in SC. We just iterate -;;; over the SC's locations. If we can't find a legal location, return NIL. +;;; Select a legal location for a load TN for Op in SC. We just +;;; iterate over the SC's locations. If we can't find a legal +;;; location, return NIL. (defun select-load-tn-location (op sc) (declare (type tn-ref op) (type sc sc)) @@ -995,9 +1006,10 @@ (defevent unpack-tn "Unpacked a TN to satisfy operand SC restriction.") -;;; Make TN's location the same as for its save TN (allocating a save TN if -;;; necessary.) Delete any save/restore code that has been emitted thus far. -;;; Mark all blocks containing references as needing to be repacked. +;;; Make TN's location the same as for its save TN (allocating a save +;;; TN if necessary.) Delete any save/restore code that has been +;;; emitted thus far. Mark all blocks containing references as needing +;;; to be repacked. (defun unpack-tn (tn) (event unpack-tn) (let ((stn (or (tn-save-tn tn) @@ -1018,17 +1030,17 @@ (defevent unpack-fallback "Unpacked some operand TN.") -;;; Called by Pack-Load-TN where there isn't any location free that we can -;;; pack into. What we do is move some live TN in one of the specified SCs to -;;; memory, then mark this block all blocks that reference the TN as needing -;;; repacking. If we succeed, we throw to UNPACKED-TN. If we fail, we return -;;; NIL. +;;; This is called by PACK-LOAD-TN where there isn't any location free +;;; that we can pack into. What we do is move some live TN in one of +;;; the specified SCs to memory, then mark this block all blocks that +;;; reference the TN as needing repacking. If we succeed, we throw to +;;; UNPACKED-TN. If we fail, we return NIL. ;;; -;;; We can unpack any live TN that appears in the NORMAL-TNs list (isn't wired -;;; or restricted.) We prefer to unpack TNs that are not used by the VOP. If -;;; we can't find any such TN, then we unpack some argument or result -;;; TN. The only way we can fail is if all locations in SC are used by -;;; load-TNs or temporaries in VOP. +;;; We can unpack any live TN that appears in the NORMAL-TNs list +;;; (isn't wired or restricted.) We prefer to unpack TNs that are not +;;; used by the VOP. If we can't find any such TN, then we unpack some +;;; argument or result TN. The only way we can fail is if all +;;; locations in SC are used by load-TNs or temporaries in VOP. (defun unpack-for-load-tn (sc op) (declare (type sc sc) (type tn-ref op)) (let ((sb (sc-sb sc)) @@ -1074,17 +1086,18 @@ nil) -;;; Try to pack a load TN in the SCs indicated by Load-SCs. If we run out -;;; of SCs, then we unpack some TN and try again. We return the packed load -;;; TN. +;;; Try to pack a load TN in the SCs indicated by Load-SCs. If we run +;;; out of SCs, then we unpack some TN and try again. We return the +;;; packed load TN. ;;; -;;; Note: we allow a Load-TN to be packed in the target location even if that -;;; location is in a SC not allowed by the primitive type. (The SC must still -;;; be allowed by the operand restriction.) This makes move VOPs more -;;; efficient, since we won't do a move from the stack into a non-descriptor -;;; any-reg though a descriptor argument load-TN. This does give targeting -;;; some real semantics, making it not a pure advisory to pack. It allows pack -;;; to do some packing it wouldn't have done before. +;;; Note: we allow a Load-TN to be packed in the target location even +;;; if that location is in a SC not allowed by the primitive type. +;;; (The SC must still be allowed by the operand restriction.) This +;;; makes move VOPs more efficient, since we won't do a move from the +;;; stack into a non-descriptor any-reg though a descriptor argument +;;; load-TN. This does give targeting some real semantics, making it +;;; not a pure advisory to pack. It allows pack to do some packing it +;;; wouldn't have done before. (defun pack-load-tn (load-scs op) (declare (type sc-vector load-scs) (type tn-ref op)) (let ((vop (tn-ref-vop op))) @@ -1116,10 +1129,10 @@ (push sc allowed))))))))) ;;; Scan a list of load-SCs vectors and a list of TN-Refs threaded by -;;; TN-Ref-Across. When we find a reference whose TN doesn't satisfy the -;;; restriction, we pack a Load-TN and load the operand into it. If a load-tn -;;; has already been allocated, we can assume that the restriction is -;;; satisfied. +;;; TN-Ref-Across. When we find a reference whose TN doesn't satisfy +;;; the restriction, we pack a Load-TN and load the operand into it. +;;; If a load-tn has already been allocated, we can assume that the +;;; restriction is satisfied. #!-sb-fluid (declaim (inline check-operand-restrictions)) (defun check-operand-restrictions (scs ops) (declare (list scs) (type (or tn-ref null) ops)) @@ -1135,7 +1148,7 @@ (sc-number (tn-sc (or load-tn (tn-ref-tn op))))))) (if load-tn - (assert (eq load-scs t)) + (aver (eq load-scs t)) (unless (eq load-scs t) (setf (tn-ref-load-tn op) (pack-load-tn (car scs) op)))))))) @@ -1150,7 +1163,7 @@ (sc-number (tn-sc (or load-tn (tn-ref-tn op))))))) (if load-tn - (assert (eq load-scs t)) + (aver (eq load-scs t)) (unless (eq load-scs t) (setf (tn-ref-load-tn op) (pack-load-tn (car scs) op)))))))) @@ -1158,8 +1171,8 @@ (values)) ;;; Scan the VOPs in Block, looking for operands whose SC restrictions -;;; aren't satisfied. We do the results first, since they are evaluated -;;; later, and our conflict analysis is a backward scan. +;;; aren't satisfied. We do the results first, since they are +;;; evaluated later, and our conflict analysis is a backward scan. (defun pack-load-tns (block) (catch 'unpacked-tn (let ((*live-block* nil) @@ -1185,10 +1198,10 @@ (setf (tn-ref-target read) write) (setf (tn-ref-target write) read)) -;;; If TN can be packed into SC so as to honor a preference to Target, then -;;; return the offset to pack at, otherwise return NIL. Target must be already -;;; packed. We can honor a preference if: -;;; -- Target's location is in SC's locations. +;;; If TN can be packed into SC so as to honor a preference to TARGET, +;;; then return the offset to pack at, otherwise return NIL. TARGET +;;; must be already packed. We can honor a preference if: +;;; -- TARGET's location is in SC's locations. ;;; -- The element sizes of the two SCs are the same. ;;; -- TN doesn't conflict with target's location. (defun check-ok-target (target tn sc) @@ -1206,11 +1219,11 @@ loc nil))) -;;; Scan along the target path from TN, looking at readers or writers. When -;;; we find a packed TN, return Check-OK-Target of that TN. If there is no -;;; target, or if the TN has multiple readers (writers), then we return NIL. -;;; We also always return NIL after 10 iterations to get around potential -;;; circularity problems. +;;; Scan along the target path from TN, looking at readers or writers. +;;; When we find a packed TN, return Check-OK-Target of that TN. If +;;; there is no target, or if the TN has multiple readers (writers), +;;; then we return NIL. We also always return NIL after 10 iterations +;;; to get around potential circularity problems. (macrolet ((frob (slot) `(let ((count 10) (current tn)) @@ -1232,31 +1245,33 @@ ;;;; location selection -;;; Select some location for TN in SC, returning the offset if we succeed, -;;; and NIL if we fail. We start scanning at the Last-Offset in an attempt -;;; to distribute the TNs across all storage. +;;; Select some location for TN in SC, returning the offset if we +;;; succeed, and NIL if we fail. We start scanning at the Last-Offset +;;; in an attempt to distribute the TNs across all storage. ;;; -;;; We call Offset-Conflicts-In-SB directly, rather than using Conflicts-In-SC. -;;; This allows us to more efficient in packing multi-location TNs: we don't -;;; have to multiply the number of tests by the TN size. This falls out -;;; natually, since we have to be aware of TN size anyway so that we don't call -;;; Conflicts-In-SC on a bogus offset. +;;; We call Offset-Conflicts-In-SB directly, rather than using +;;; Conflicts-In-SC. This allows us to more efficient in packing +;;; multi-location TNs: we don't have to multiply the number of tests +;;; by the TN size. This falls out natually, since we have to be aware +;;; of TN size anyway so that we don't call Conflicts-In-SC on a bogus +;;; offset. ;;; -;;; We give up on finding a location after our current pointer has wrapped -;;; twice. This will result in testing some locations twice in the case that -;;; we fail, but is simpler than trying to figure out the soonest failure -;;; point. +;;; We give up on finding a location after our current pointer has +;;; wrapped twice. This will result in testing some locations twice in +;;; the case that we fail, but is simpler than trying to figure out +;;; the soonest failure point. ;;; -;;; We also give up without bothering to wrap if the current size isn't large -;;; enough to hold a single element of element-size without bothering to wrap. -;;; If it doesn't fit this iteration, it won't fit next. +;;; We also give up without bothering to wrap if the current size +;;; isn't large enough to hold a single element of element-size +;;; without bothering to wrap. If it doesn't fit this iteration, it +;;; won't fit next. ;;; -;;; ### Note that we actually try to pack as many consecutive TNs as possible -;;; in the same location, since we start scanning at the same offset that the -;;; last TN was successfully packed in. This is a weakening of the scattering -;;; hueristic that was put in to prevent restricted VOP temps from hogging all -;;; of the registers. This way, all of these temps probably end up in one -;;; register. +;;; ### Note that we actually try to pack as many consecutive TNs as +;;; possible in the same location, since we start scanning at the same +;;; offset that the last TN was successfully packed in. This is a +;;; weakening of the scattering hueristic that was put in to prevent +;;; restricted VOP temps from hogging all of the registers. This way, +;;; all of these temps probably end up in one register. (defun select-location (tn sc &optional use-reserved-locs) (declare (type tn tn) (type sc sc) (inline member)) (let* ((sb (sc-sb sc)) @@ -1294,8 +1309,8 @@ (return)))) (incf current-start alignment)))))) -;;; If a save TN, return the saved TN, otherwise return TN. Useful for -;;; getting the conflicts of a TN that might be a save TN. +;;; If a save TN, return the saved TN, otherwise return TN. This is +;;; useful for getting the conflicts of a TN that might be a save TN. (defun original-tn (tn) (declare (type tn tn)) (if (member (tn-kind tn) '(:save :save-once :specified-save)) @@ -1343,7 +1358,7 @@ (when (eq (sb-kind (sc-sb sc)) :unbounded) (grow-sc sc) (or (select-location original sc) - (error "Failed to pack after growing SC?")))))) + (error "failed to pack after growing SC?")))))) (when loc (add-location-conflicts original sc loc) (setf (tn-sc tn) sc) @@ -1352,16 +1367,16 @@ (values)) -;;; Pack a wired TN, checking that the offset is in bounds for the SB, and -;;; that the TN doesn't conflict with some other TN already packed in that -;;; location. If the TN is wired to a location beyond the end of a :Unbounded -;;; SB, then grow the SB enough to hold the TN. +;;; Pack a wired TN, checking that the offset is in bounds for the SB, +;;; and that the TN doesn't conflict with some other TN already packed +;;; in that location. If the TN is wired to a location beyond the end +;;; of a :Unbounded SB, then grow the SB enough to hold the TN. ;;; -;;; ### Checking for conflicts is disabled for :SPECIFIED-SAVE TNs. This is -;;; kind of a hack to make specifying wired stack save locations for local call -;;; arguments (such as OLD-FP) work, since the caller and callee OLD-FP save -;;; locations may conflict when the save locations don't really (due to being -;;; in different frames.) +;;; ### Checking for conflicts is disabled for :SPECIFIED-SAVE TNs. +;;; This is kind of a hack to make specifying wired stack save +;;; locations for local call arguments (such as OLD-FP) work, since +;;; the caller and callee OLD-FP save locations may conflict when the +;;; save locations don't really (due to being in different frames.) (defun pack-wired-tn (tn) (declare (type tn tn)) (let* ((sc (tn-sc tn)) @@ -1374,16 +1389,16 @@ (error "~S is wired to a location that is out of bounds." tn)) (grow-sc sc end)) - ;; For non-x86 ports the presence of a save-tn associated with a tn is used - ;; to identify the old-fp and return-pc tns. It depends on the old-fp and - ;; return-pc being passed in registers. + ;; For non-x86 ports the presence of a save-tn associated with a + ;; tn is used to identify the old-fp and return-pc tns. It depends + ;; on the old-fp and return-pc being passed in registers. #!-x86 (when (and (not (eq (tn-kind tn) :specified-save)) (conflicts-in-sc original sc offset)) (error "~S is wired to a location that it conflicts with." tn)) - ;; Use the above check, but only print a verbose warning. This can be - ;; helpful for debugging the x86 port. + ;; Use the above check, but only print a verbose warning. This can + ;; be helpful for debugging the x86 port. #+nil (when (and (not (eq (tn-kind tn) :specified-save)) (conflicts-in-sc original sc offset)) @@ -1400,10 +1415,10 @@ original (tn-save-tn tn) (tn-kind (tn-save-tn tn)))) - ;; On the x86 ports the old-fp and return-pc are often passed on the stack - ;; so the above hack for the other ports does not always work. Here the - ;; old-fp and return-pc tns are identified by being on the stack in their - ;; standard save locations. + ;; On the x86 ports the old-fp and return-pc are often passed on + ;; the stack so the above hack for the other ports does not always + ;; work. Here the old-fp and return-pc tns are identified by being + ;; on the stack in their standard save locations. #!+x86 (when (and (not (eq (tn-kind tn) :specified-save)) (not (and (string= (sb-name sb) "STACK") @@ -1417,7 +1432,7 @@ (defevent repack-block "Repacked a block due to TN unpacking.") (defun pack (component) - (assert (not *in-pack*)) + (aver (not *in-pack*)) (let ((*in-pack* t) (optimize (policy nil (or (>= speed compilation-speed) (>= space compilation-speed)))) @@ -1450,16 +1465,16 @@ (unless (tn-offset tn) (pack-tn tn t))) - ;; Assign costs to normal TNs so we know which ones should always be - ;; packed on the stack. + ;; Assign costs to normal TNs so we know which ones should always + ;; be packed on the stack. (when (and optimize *pack-assign-costs*) (assign-tn-costs component)) ;; Pack normal TNs in the order that they appear in the code. This - ;; should have some tendency to pack important TNs first, since control - ;; analysis favors the drop-through. This should also help targeting, - ;; since we will pack the target TN soon after we determine the location - ;; of the targeting TN. + ;; should have some tendency to pack important TNs first, since + ;; control analysis favors the drop-through. This should also help + ;; targeting, since we will pack the target TN soon after we + ;; determine the location of the targeting TN. (do-ir2-blocks (block component) (let ((ltns (ir2-block-local-tns block))) (do ((i (1- (ir2-block-local-tn-count block)) (1- i))) @@ -1469,8 +1484,8 @@ (unless (or (null tn) (eq tn :more) (tn-offset tn)) (pack-tn tn nil)))))) - ;; Pack any leftover normal TNs. This is to deal with :MORE TNs, which - ;; could possibly not appear in any local TN map. + ;; Pack any leftover normal TNs. This is to deal with :MORE TNs, + ;; which could possibly not appear in any local TN map. (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn))) ((null tn)) (unless (tn-offset tn) diff --git a/src/compiler/represent.lisp b/src/compiler/represent.lisp index e53d400..ab4403e 100644 --- a/src/compiler/represent.lisp +++ b/src/compiler/represent.lisp @@ -39,7 +39,7 @@ (load load (cdr load)) (n 0 (1+ n))) ((null costs) - (assert more-cost) + (aver more-cost) (values arg-p (+ n (or (position-in #'tn-ref-across ref refs) @@ -525,7 +525,7 @@ (tn-ref-across val)) (pass pass-locs (cdr pass))) ((null val) - (assert (null pass))) + (aver (null pass))) (let* ((val-tn (tn-ref-tn val)) (pass-tn (first pass)) (pass-sc (tn-sc pass-tn)) @@ -540,7 +540,7 @@ (cond ((not (sc-number-stack-p pass-sc)) fp-tn) (nfp-tn) (t - (assert (eq how :known-return)) + (aver (eq how :known-return)) (setq nfp-tn (make-number-stack-pointer-tn)) (setf (tn-sc nfp-tn) (svref *backend-sc-numbers* @@ -550,14 +550,14 @@ node block (template-or-lose 'compute-old-nfp) nfp-tn vop) - (assert (not (sc-number-stack-p (tn-sc nfp-tn)))) + (aver (not (sc-number-stack-p (tn-sc nfp-tn)))) nfp-tn))) (new (emit-move-arg-template node block res val-tn this-fp pass-tn vop)) (after (cond ((eq how :local-call) - (assert (eq (vop-info-name (vop-info prev)) - 'allocate-frame)) + (aver (eq (vop-info-name (vop-info prev)) + 'allocate-frame)) prev) (prev (vop-next prev)) (t @@ -634,7 +634,7 @@ (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn))) ((null tn)) - (assert (tn-primitive-type tn)) + (aver (tn-primitive-type tn)) (unless (tn-sc tn) (let* ((scs (primitive-type-scs (tn-primitive-type tn)))) (cond ((rest scs) @@ -649,13 +649,13 @@ (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn))) ((null tn)) - (assert (tn-primitive-type tn)) + (aver (tn-primitive-type tn)) (unless (tn-sc tn) (let* ((scs (primitive-type-scs (tn-primitive-type tn))) (sc (if (rest scs) (select-tn-representation tn scs costs) (svref *backend-sc-numbers* (first scs))))) - (assert sc) + (aver sc) (setf (tn-sc tn) sc)))) (do ((alias (ir2-component-alias-tns 2comp) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 5fc13af..a9c1533 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -867,8 +867,8 @@ ;; (float +0.0 +0.0) => (member 0.0) ;; (float -0.0 -0.0) => (member -0.0) ((and lo-float-zero-p hi-float-zero-p) - ;; Shouldn't have exclusive bounds here. - (assert (and (not (consp lo)) (not (consp hi)))) + ;; shouldn't have exclusive bounds here.. + (aver (and (not (consp lo)) (not (consp hi)))) (if (= lo-float-zero-p hi-float-zero-p) ;; (float +0.0 +0.0) => (member 0.0) ;; (float -0.0 -0.0) => (member -0.0) @@ -1000,7 +1000,7 @@ (let* ((members (member-type-members arg)) (member (first members)) (member-type (type-of member))) - (assert (not (rest members))) + (aver (not (rest members))) (specifier-type `(,(if (subtypep member-type 'integer) 'integer member-type) diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp index 859bb93..508b6ef 100644 --- a/src/compiler/stack.lisp +++ b/src/compiler/stack.lisp @@ -35,7 +35,7 @@ (not (eq (node-block dest) block)) 2cont (eq (ir2-continuation-kind 2cont) :unknown)) - (assert (or saw-last (not last-pop))) + (aver (or saw-last (not last-pop))) (pushed cont))))) (setf (ir2-block-pushed 2block) (pushed)))) @@ -89,7 +89,7 @@ (dolist (push (reverse (ir2-block-pushed 2block))) (if (eq (car new-stack) push) (pop new-stack) - (assert (not (member push new-stack))))) + (aver (not (member push new-stack))))) (dolist (pop (reverse (ir2-block-popped 2block))) (push pop new-stack)) @@ -99,12 +99,12 @@ (when new-stack (dolist (pred (block-pred block)) (if (eq pred (component-head (block-component block))) - (assert (find block - (environment-nlx-info (block-environment block)) - :key #'nlx-info-target)) + (aver (find block + (environment-nlx-info (block-environment block)) + :key #'nlx-info-target)) (let ((pred-stack (ir2-block-end-stack (block-info pred)))) (unless (tailp new-stack pred-stack) - (assert (search pred-stack new-stack)) + (aver (search pred-stack new-stack)) (stack-simulation-walk pred new-stack)))))))) (values)) @@ -134,9 +134,9 @@ ((null pushes)) (let ((push (first pushes))) (cond ((member push stack) - (assert (not popping))) + (aver (not popping))) ((eq push tailp-cont) - (assert (null (rest pushes)))) + (aver (null (rest pushes)))) (t (push push (ir2-block-end-stack 2block)) (setq popping t)))))) @@ -166,7 +166,7 @@ (- (length block1-stack) (length block2-stack) 1)))) - (assert (tailp block2-stack block1-stack)) + (aver (tailp block2-stack block1-stack)) (let* ((block (insert-cleanup-code block1 block2 (continuation-next (block-start block2)) diff --git a/src/compiler/tn.lisp b/src/compiler/tn.lisp index c344725..042d247 100644 --- a/src/compiler/tn.lisp +++ b/src/compiler/tn.lisp @@ -142,14 +142,14 @@ ;;; code, but may result in the TN sometimes not being live when you want it. (defun environment-live-tn (tn env) (declare (type tn tn) (type environment env)) - (assert (eq (tn-kind tn) :normal)) + (aver (eq (tn-kind tn) :normal)) (setf (tn-kind tn) :environment) (setf (tn-environment tn) env) (push tn (ir2-environment-live-tns (environment-info env))) tn) (defun environment-debug-live-tn (tn env) (declare (type tn tn) (type environment env)) - (assert (eq (tn-kind tn) :normal)) + (aver (eq (tn-kind tn) :normal)) (setf (tn-kind tn) :debug-environment) (setf (tn-environment tn) env) (push tn (ir2-environment-debug-live-tns (environment-info env))) @@ -158,7 +158,7 @@ ;;; Make TN be live throughout the current component. Return TN. (defun component-live-tn (tn) (declare (type tn tn)) - (assert (eq (tn-kind tn) :normal)) + (aver (eq (tn-kind tn) :normal)) (setf (tn-kind tn) :component) (push tn (ir2-component-component-tns (component-info *component-being-compiled*))) @@ -167,8 +167,8 @@ ;;; Specify that Save be used as the save location for TN. TN is returned. (defun specify-save-tn (tn save) (declare (type tn tn save)) - (assert (eq (tn-kind save) :normal)) - (assert (and (not (tn-save-tn tn)) (not (tn-save-tn save)))) + (aver (eq (tn-kind save) :normal)) + (aver (and (not (tn-save-tn tn)) (not (tn-save-tn save)))) (setf (tn-kind save) :specified-save) (setf (tn-save-tn tn) save) (setf (tn-save-tn save) tn) @@ -360,7 +360,7 @@ (defun drop-thru-p (node block) (declare (type node node) (type cblock block)) (let ((next-block (ir2-block-next (block-info (node-block node))))) - (assert (eq node (block-last (node-block node)))) + (aver (eq node (block-last (node-block node)))) (eq next-block (block-info block)))) ;;; Link a list of VOPs from First to Last into Block, Before the specified @@ -423,7 +423,7 @@ ;;; Return the value of an immediate constant TN. (defun tn-value (tn) (declare (type tn tn)) - (assert (member (tn-kind tn) '(:constant :cached-constant))) + (aver (member (tn-kind tn) '(:constant :cached-constant))) (constant-value (tn-leaf tn))) ;;; Force TN to be allocated in a SC that doesn't need to be saved: an diff --git a/src/compiler/trace-table.lisp b/src/compiler/trace-table.lisp index b25f0a1..1abbee4 100644 --- a/src/compiler/trace-table.lisp +++ b/src/compiler/trace-table.lisp @@ -59,7 +59,7 @@ (let* ((posn (label-position (car entry))) (state (cdr entry))) (declare (type index posn) (type tt-state state)) - (assert (<= last-posn posn)) + (aver (<= last-posn posn)) (do ((offset (- posn last-posn) (- offset tt-max-offset))) ((< offset tt-max-offset) (push-entry offset state)) diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 1c72075..ed0cb35 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -94,7 +94,7 @@ (continuation-use (basic-combination-fun node)))) *backend-predicate-types*))) - (assert ctype) + (aver ctype) (ir1-transform-type-predicate object ctype))) ;;; If FIND-CLASS is called on a constant class, locate the CLASS-CELL @@ -398,7 +398,7 @@ ;;; sometimes be generated when byte compiling inline functions, but ;;; it's quite uncommon.) -- WHN 20000523 (deftransform %instance-typep ((object spec) * * :when :both) - (assert (constant-continuation-p spec)) + (aver (constant-continuation-p spec)) (let* ((spec (continuation-value spec)) (class (specifier-type spec)) (name (sb!xc:class-name class)) diff --git a/src/compiler/x86/alloc.lisp b/src/compiler/x86/alloc.lisp index 9e74f3b..34a099c 100644 --- a/src/compiler/x86/alloc.lisp +++ b/src/compiler/x86/alloc.lisp @@ -57,7 +57,7 @@ (t (storew nil-value ptr cons-cdr-slot list-pointer-type))) - (assert (null (tn-ref-across things))))) + (aver (null (tn-ref-across things))))) (move result res)))))) (define-vop (list list-or-list*) diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp index 76bc9a9..8cfd2e7 100644 --- a/src/compiler/x86/c-call.lisp +++ b/src/compiler/x86/c-call.lisp @@ -194,7 +194,7 @@ (:info amount) (:results (result :scs (sap-reg any-reg))) (:generator 0 - (assert (location= result esp-tn)) + (aver (location= result esp-tn)) (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) (inst sub esp-tn delta))) @@ -211,7 +211,7 @@ (:info amount) (:results (result :scs (sap-reg any-reg))) (:generator 0 - (assert (not (location= result esp-tn))) + (aver (not (location= result esp-tn))) (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) (inst sub (make-ea :dword diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 04d0f62..307e3f8 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -748,7 +748,7 @@ ;;; more arg, but there is no new-FP, since the arguments have been set up in ;;; the current frame. (macrolet ((define-full-call (name named return variable) - (assert (not (and variable (eq return :tail)))) + (aver (not (and variable (eq return :tail)))) `(define-vop (,name ,@(when (eq return :unknown) '(unknown-values-receiver))) diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index d8ea764..de09877 100644 --- a/src/compiler/x86/float.lisp +++ b/src/compiler/x86/float.lisp @@ -100,7 +100,7 @@ ;;; ;;; Using a Pop then load. (defun copy-fp-reg-to-fr0 (reg) - (assert (not (zerop (tn-offset reg)))) + (aver (not (zerop (tn-offset reg)))) (inst fstp fr0-tn) (inst fld (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) @@ -108,7 +108,7 @@ ;;; Using Fxch then Fst to restore the original reg contents. #+nil (defun copy-fp-reg-to-fr0 (reg) - (assert (not (zerop (tn-offset reg)))) + (aver (not (zerop (tn-offset reg)))) (inst fxch reg) (inst fst reg)) @@ -1821,7 +1821,7 @@ (signed-reg (inst mov res bits)) (signed-stack - (assert (location= bits res))))) + (aver (location= bits res))))) (single-reg (sc-case bits (signed-reg diff --git a/src/compiler/x86/insts.lisp b/src/compiler/x86/insts.lisp index 6441221..914918c 100644 --- a/src/compiler/x86/insts.lisp +++ b/src/compiler/x86/insts.lisp @@ -634,7 +634,7 @@ (defun reg-tn-encoding (tn) (declare (type tn tn)) - (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers)) + (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers)) (let ((offset (tn-offset tn))) (logior (ash (logand offset 1) 2) (ash offset -1)))) @@ -902,7 +902,7 @@ (emit-byte segment (if (eq size :byte) #b10001000 #b10001001)) (emit-ea segment dst (reg-tn-encoding src))) ((fixup-p src) - (assert (eq size :dword)) + (aver (eq size :dword)) (emit-byte segment #b11000111) (emit-ea segment dst #b000) (emit-absolute-fixup segment src)) @@ -910,12 +910,12 @@ (error "bogus arguments to MOV: ~S ~S" dst src)))))) (defun emit-move-with-extension (segment dst src opcode) - (assert (register-p dst)) + (aver (register-p dst)) (let ((dst-size (operand-size dst)) (src-size (operand-size src))) (ecase dst-size (:word - (assert (eq src-size :byte)) + (aver (eq src-size :byte)) (maybe-emit-operand-size-prefix segment :word) (emit-byte segment #b00001111) (emit-byte segment opcode) @@ -966,7 +966,7 @@ (emit-absolute-fixup segment src)) (t (let ((size (operand-size src))) - (assert (not (eq size :byte))) + (aver (not (eq size :byte))) (maybe-emit-operand-size-prefix segment size) (cond ((register-p src) (emit-byte-with-reg segment #b01010 (reg-tn-encoding src))) @@ -984,7 +984,7 @@ (:printer reg/mem ((op '(#b1000111 #b000)) (width 1))) (:emitter (let ((size (operand-size dst))) - (assert (not (eq size :byte))) + (aver (not (eq size :byte))) (maybe-emit-operand-size-prefix segment size) (cond ((register-p dst) (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst))) @@ -1028,7 +1028,7 @@ (define-instruction lea (segment dst src) (:printer reg-reg/mem ((op #b1000110) (width 1))) (:emitter - (assert (dword-reg-p dst)) + (aver (dword-reg-p dst)) (emit-byte segment #b10001101) (emit-ea segment src (reg-tn-encoding dst)))) @@ -1036,7 +1036,7 @@ ;; Register/Memory with Register. (:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg)) (:emitter - (assert (register-p src)) + (aver (register-p src)) (let ((size (matching-operand-size src dst))) (maybe-emit-operand-size-prefix segment size) (emit-byte segment #b00001111) @@ -1240,7 +1240,7 @@ (:printer accum-reg/mem ((op '(#b1111011 #b100)))) (:emitter (let ((size (matching-operand-size dst src))) - (assert (accumulator-p dst)) + (aver (accumulator-p dst)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) (emit-ea segment src #b100)))) @@ -1283,7 +1283,7 @@ (:printer accum-reg/mem ((op '(#b1111011 #b110)))) (:emitter (let ((size (matching-operand-size dst src))) - (assert (accumulator-p dst)) + (aver (accumulator-p dst)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) (emit-ea segment src #b110)))) @@ -1292,7 +1292,7 @@ (:printer accum-reg/mem ((op '(#b1111011 #b111)))) (:emitter (let ((size (matching-operand-size dst src))) - (assert (accumulator-p dst)) + (aver (accumulator-p dst)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) (emit-ea segment src #b111)))) @@ -1338,7 +1338,7 @@ ;; Register/Memory with Register. (:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg)) (:emitter - (assert (register-p src)) + (aver (register-p src)) (let ((size (matching-operand-size src dst))) (maybe-emit-operand-size-prefix segment size) (emit-byte segment #b00001111) @@ -1516,7 +1516,7 @@ (:printer string-op ((op #b0110110))) (:emitter (let ((size (operand-size acc))) - (assert (accumulator-p acc)) + (aver (accumulator-p acc)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b01101100 #b01101101))))) @@ -1524,7 +1524,7 @@ (:printer string-op ((op #b1010110))) (:emitter (let ((size (operand-size acc))) - (assert (accumulator-p acc)) + (aver (accumulator-p acc)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b10101100 #b10101101))))) @@ -1538,7 +1538,7 @@ (:printer string-op ((op #b0110111))) (:emitter (let ((size (operand-size acc))) - (assert (accumulator-p acc)) + (aver (accumulator-p acc)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b01101110 #b01101111))))) @@ -1546,7 +1546,7 @@ (:printer string-op ((op #b1010111))) (:emitter (let ((size (operand-size acc))) - (assert (accumulator-p acc)) + (aver (accumulator-p acc)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b10101110 #b10101111))))) @@ -1554,7 +1554,7 @@ (:printer string-op ((op #b1010101))) (:emitter (let ((size (operand-size acc))) - (assert (accumulator-p acc)) + (aver (accumulator-p acc)) (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b10101010 #b10101011))))) @@ -1658,7 +1658,7 @@ 1 #'(lambda (segment posn) (let ((disp (- (label-position target) (1+ posn)))) - (assert (<= -128 disp 127)) + (aver (<= -128 disp 127)) (emit-byte segment disp))))) (define-instruction jmp (segment cond &optional where) @@ -2045,14 +2045,14 @@ (define-instruction fadd-sti (segment destination) (:printer floating-point-fp ((op '(#b100 #b000)))) (:emitter - (assert (fp-reg-tn-p destination)) + (aver (fp-reg-tn-p destination)) (emit-byte segment #b11011100) (emit-fp-op segment destination #b000))) ;;; with pop (define-instruction faddp-sti (segment destination) (:printer floating-point-fp ((op '(#b110 #b000)))) (:emitter - (assert (fp-reg-tn-p destination)) + (aver (fp-reg-tn-p destination)) (emit-byte segment #b11011110) (emit-fp-op segment destination #b000))) @@ -2102,14 +2102,14 @@ (define-instruction fsub-sti (segment destination) (:printer floating-point-fp ((op '(#b100 #b101)))) (:emitter - (assert (fp-reg-tn-p destination)) + (aver (fp-reg-tn-p destination)) (emit-byte segment #b11011100) (emit-fp-op segment destination #b101))) ;;; with a pop (define-instruction fsubp-sti (segment destination) (:printer floating-point-fp ((op '(#b110 #b101)))) (:emitter - (assert (fp-reg-tn-p destination)) + (aver (fp-reg-tn-p destination)) (emit-byte segment #b11011110) (emit-fp-op segment destination #b101))) @@ -2121,14 +2121,14 @@ (define-instruction fsubr-sti (segment destination) (:printer floating-point-fp ((op '(#b100 #b100)))) (:emitter - (assert (fp-reg-tn-p destination)) + (aver (fp-reg-tn-p destination)) (emit-byte segment #b11011100) (emit-fp-op segment destination #b100))) ;;; with a pop (define-instruction fsubrp-sti (segment destination) (:printer floating-point-fp ((op '(#b110 #b100)))) (:emitter - (assert (fp-reg-tn-p destination)) + (aver (fp-reg-tn-p destination)) (emit-byte segment #b11011110) (emit-fp-op segment destination #b100))) @@ -2156,7 +2156,7 @@ (define-instruction fmul-sti (segment destination) (:printer floating-point-fp ((op '(#b100 #b001)))) (:emitter - (assert (fp-reg-tn-p destination)) + (aver (fp-reg-tn-p destination)) (emit-byte segment #b11011100) (emit-fp-op segment destination #b001))) @@ -2206,7 +2206,7 @@ (define-instruction fdiv-sti (segment destination) (:printer floating-point-fp ((op '(#b100 #b111)))) (:emitter - (assert (fp-reg-tn-p destination)) + (aver (fp-reg-tn-p destination)) (emit-byte segment #b11011100) (emit-fp-op segment destination #b111))) @@ -2218,7 +2218,7 @@ (define-instruction fdivr-sti (segment destination) (:printer floating-point-fp ((op '(#b100 #b110)))) (:emitter - (assert (fp-reg-tn-p destination)) + (aver (fp-reg-tn-p destination)) (emit-byte segment #b11011100) (emit-fp-op segment destination #b110))) @@ -2429,7 +2429,7 @@ ;; XX Printer conflicts with frstor ;; (:printer floating-point ((op '(#b101 #b100)))) (:emitter - (assert (fp-reg-tn-p src)) + (aver (fp-reg-tn-p src)) (emit-byte segment #b11011101) (emit-fp-op segment src #b100))) diff --git a/src/compiler/x86/move.lisp b/src/compiler/x86/move.lisp index a8f47e1..0286e9a 100644 --- a/src/compiler/x86/move.lisp +++ b/src/compiler/x86/move.lisp @@ -280,7 +280,7 @@ (:note "signed word to integer coercion") (:node-var node) (:generator 20 - (assert (not (location= x y))) + (aver (not (location= x y))) (let ((bignum (gen-label)) (done (gen-label))) (inst mov y x) @@ -341,9 +341,9 @@ (:node-var node) (:note "unsigned word to integer coercion") (:generator 20 - (assert (not (location= x y))) - (assert (not (location= x alloc))) - (assert (not (location= y alloc))) + (aver (not (location= x y))) + (aver (not (location= x alloc))) + (aver (not (location= y alloc))) (let ((bignum (gen-label)) (done (gen-label)) (one-word-bignum (gen-label)) diff --git a/src/compiler/x86/nlx.lisp b/src/compiler/x86/nlx.lisp index c15ba61..b098811 100644 --- a/src/compiler/x86/nlx.lisp +++ b/src/compiler/x86/nlx.lisp @@ -22,7 +22,7 @@ (make-wired-tn *fixnum-primitive-type* any-reg-sc-number ebx-offset)) (defun catch-block-ea (tn) - (assert (sc-is tn catch-block)) + (aver (sc-is tn catch-block)) (make-ea :dword :base ebp-tn :disp (- (* (+ (tn-offset tn) catch-block-size) word-bytes)))) diff --git a/src/compiler/x86/static-fn.lisp b/src/compiler/x86/static-fn.lisp index 231e074..111701b 100644 --- a/src/compiler/x86/static-fn.lisp +++ b/src/compiler/x86/static-fn.lisp @@ -37,11 +37,10 @@ (moves))) (defun static-function-template-vop (num-args num-results) - (assert (and (<= num-args register-arg-count) + (unless (and (<= num-args register-arg-count) (<= num-results register-arg-count)) - (num-args num-results) - "Either too many args (~D) or too many results (~D). Max = ~D" - num-args num-results register-arg-count) + (error "either too many args (~D) or too many results (~D); max = ~D" + num-args num-results register-arg-count)) (let ((num-temps (max num-args num-results))) (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results)) (dotimes (i num-results) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 373ee53..d030e5b 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -636,13 +636,13 @@ (lclass-pcl-class (sb-kernel:class-pcl-class lclass)) (olclass (cl:find-class name nil))) (if lclass-pcl-class - (assert (eq class lclass-pcl-class)) + (aver (eq class lclass-pcl-class)) (setf (sb-kernel:class-pcl-class lclass) class)) (update-lisp-class-layout class layout) (cond (olclass - (assert (eq lclass olclass))) + (aver (eq lclass olclass))) (t (setf (cl:find-class name) lclass))))) diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index bf3ce0d..d908ea4 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -335,9 +335,9 @@ (found (unless (sb-kernel:class-pcl-class found) (setf (sb-kernel:class-pcl-class found) class)) - (assert (eq (sb-kernel:class-pcl-class found) class)) + (aver (eq (sb-kernel:class-pcl-class found) class)) (let ((layout (sb-kernel:class-layout found))) - (assert layout) + (aver layout) layout)) (t (make-wrapper-internal @@ -370,7 +370,7 @@ (let ((found (cl:find-class (slot-value class 'name)))) (unless (sb-kernel:class-pcl-class found) (setf (sb-kernel:class-pcl-class found) class)) - (assert (eq (sb-kernel:class-pcl-class found) class)) + (aver (eq (sb-kernel:class-pcl-class found) class)) found)) (t (sb-kernel:make-standard-class :pcl-class class)))) @@ -381,8 +381,8 @@ (layout (sb-kernel:class-layout found))) (unless (sb-kernel:class-pcl-class found) (setf (sb-kernel:class-pcl-class found) class)) - (assert (eq (sb-kernel:class-pcl-class found) class)) - (assert layout) + (aver (eq (sb-kernel:class-pcl-class found) class)) + (aver layout) layout)))) ;;; FIXME: The immediately following macros could become inline functions. diff --git a/src/pcl/fin.lisp b/src/pcl/fin.lisp index 20a24e0..2c18c69 100644 --- a/src/pcl/fin.lisp +++ b/src/pcl/fin.lisp @@ -78,7 +78,7 @@ ;;; Set the function that is called when FIN is called. (defun set-funcallable-instance-function (fin new-value) (declare (type function new-value)) - (assert (funcallable-instance-p fin)) + (aver (funcallable-instance-p fin)) (setf (sb-kernel:funcallable-instance-function fin) new-value)) ;;; This "works" on non-PCL FINs, which allows us to weaken diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index f09eba4..e9539ec 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -206,7 +206,7 @@ (defmacro get-wrapper (inst) (once-only ((wrapper `(wrapper-of ,inst))) `(progn - (assert (typep ,wrapper 'wrapper) () "What kind of instance is this?") + (aver (typep ,wrapper 'wrapper)) ,wrapper))) ;;; FIXME: could be an inline function (like many other things around diff --git a/version.lisp-expr b/version.lisp-expr index 7ea2d1f..97bd941 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.11.22" +"0.6.11.23"