(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
(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)
(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)))
(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))
(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.
(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)))
(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)
(declare (type combination call) (type continuation cont)
(type template template) (list rtypes))
(let* ((dtype (node-derived-type call))
- (type (if (and (or (eq (template-policy template) :safe)
+ (type (if (and (or (eq (template-ltn-policy template) :safe)
(policy call (= safety 0)))
(continuation-type-check cont))
(values-type-intersection
(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))
(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)
(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))))))))
arg-locs nargs)))))
(values))
+;;; stuff to check in CHECK-FULL-CALL
+;;;
+;;; There are some things which are intended always to be optimized
+;;; away by DEFTRANSFORMs and such, and so never compiled into full
+;;; calls. This has been a source of bugs so many times that it seems
+;;; worth listing some of them here so that we can check the list
+;;; whenever we compile a full call.
+;;;
+;;; FIXME: It might be better to represent this property by setting a
+;;; flag in DEFKNOWN, instead of representing it by membership in this
+;;; list.
+(defvar *always-optimized-away*
+ '(;; This should always be DEFTRANSFORMed away, but wasn't in a bug
+ ;; reported to cmucl-imp@cons.org 2000-06-20.
+ %instance-ref
+ ;; These should always turn into VOPs, but wasn't in a bug which
+ ;; appeared when LTN-POLICY stuff was being tweaked in
+ ;; sbcl-0.6.9.16. in sbcl-0.6.0
+ data-vector-set
+ data-vector-ref))
+
+;;; more stuff to check in CHECK-FULL-CALL
+;;;
;;; These came in handy when troubleshooting cold boot after making
;;; major changes in the package structure: various transforms and
;;; VOPs and stuff got attached to the wrong symbol, so that
#!+sb-show (defvar *show-full-called-fnames-p* nil)
#!+sb-show (defvar *full-called-fnames* (make-hash-table :test 'equal))
-;;; If the call is in a tail recursive position and the return
-;;; convention is standard, then do a tail full call. If one or fewer
-;;; values are desired, then use a single-value call, otherwise use a
-;;; multiple-values call.
-(defun ir2-convert-full-call (node block)
- (declare (type combination node) (type ir2-block block))
-
+;;; Do some checks on a full call:
+;;; * Is this a full call to something we have reason to know should
+;;; never be full called?
+;;; * Is this a full call to (SETF FOO) which might conflict with
+;;; a DEFSETF or some such thing elsewhere in the program?
+(defun check-full-call (node)
(let* ((cont (basic-combination-fun node))
(fname (continuation-function-name cont t)))
(declare (type (or symbol cons) fname))
#!+sb-show (when *show-full-called-fnames-p*
(/show "converting full call to named function" fname)
(/show (basic-combination-args node))
+ (/show (policy node speed) (policy node safety))
+ (/show (policy node compilation-speed))
(let ((arg-types (mapcar (lambda (maybe-continuation)
(when maybe-continuation
(type-specifier
(basic-combination-args node))))
(/show arg-types)))
+ (when (memq fname *always-optimized-away*)
+ (/show (policy node speed) (policy node safety))
+ (/show (policy node compilation-speed))
+ (error "internal error: full call to ~S" fname))
+
(when (consp fname)
(destructuring-bind (setf stem) fname
- (assert (eq setf 'setf))
- (setf (gethash stem *setf-assumed-fboundp*) t))))
+ (aver (eq setf 'setf))
+ (setf (gethash stem *setf-assumed-fboundp*) t)))))
+;;; If the call is in a tail recursive position and the return
+;;; convention is standard, then do a tail full call. If one or fewer
+;;; values are desired, then use a single-value call, otherwise use a
+;;; multiple-values call.
+(defun ir2-convert-full-call (node block)
+ (declare (type combination node) (type ir2-block block))
+ (check-full-call node)
(let ((2cont (continuation-info (node-cont node))))
(cond ((node-tail-p node)
(ir2-convert-tail-full-call node block))
(ir2-convert-multiple-full-call node block))
(t
(ir2-convert-fixed-full-call node block))))
-
(values))
\f
;;;; entering functions
(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)
(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))
(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)))
;;; 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)
(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))))
;;; 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)))))
(defoptimizer (%special-unbind ir2-convert) ((var) node block)
(vop unbind node block))
-;;; ### Not clear that this really belongs in this file, or should
-;;; really be done this way, but this is the least violation of
+;;; ### It's not clear that this really belongs in this file, or
+;;; should really be done this way, but this is the least violation of
;;; abstraction in the current setup. We don't want to wire
;;; shallow-binding assumptions into IR1tran.
(def-ir1-translator progv ((vars vals &body body) start cont)
(ir1-convert
start cont
- (if (or *converting-for-interpreter* (byte-compiling))
+ (if (byte-compiling)
`(%progv ,vars ,vals #'(lambda () ,@body))
(once-only ((n-save-bs '(%primitive current-binding-pointer)))
`(unwind-protect
\f
;;;; n-argument functions
-(macrolet ((frob (name)
+(macrolet ((def-frob (name)
`(defoptimizer (,name ir2-convert) ((&rest args) node block)
(let* ((refs (move-tail-full-call-args node block))
(cont (node-cont node))
(vop* ,name node block (refs) ((first res) nil)
(length args))
(move-continuation-result node block res cont)))))
- (frob list)
- (frob list*))
+ (def-frob list)
+ (def-frob list*))
\f
;;;; structure accessors
;;;;
(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)
(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)))))))
projects / sbcl.git / blobdiff