X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=d32325b6923caed5e75b8358a01de555cb37266c;hb=6c4d4d984b1af6b2a73568cec3ab9c8795cff2da;hp=7e42924b763feb86827000bb7807db47106d6f0c;hpb=34dd23563d2f5cf05c72b971da0d0b065a09bf2a;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 7e42924..d32325b 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -266,7 +266,7 @@ ;;;; utilities for receiving fixed values ;;; Return a TN that can be referenced to get the value of CONT. CONT -;;; must be LTN-Annotated either as a delayed leaf ref or as a fixed, +;;; must be LTN-ANNOTATED either as a delayed leaf ref or as a fixed, ;;; single-value continuation. If a type check is called for, do it. ;;; ;;; The primitive-type of the result will always be the same as the @@ -470,7 +470,7 @@ ;;;; template conversion -;;; Build a TN-Refs list that represents access to the values of the +;;; Build a TN-REFS list that represents access to the values of the ;;; specified list of continuations ARGS for TEMPLATE. Any :CONSTANT ;;; arguments are returned in the second value as a list rather than ;;; being accessed as a normal argument. NODE and BLOCK provide the @@ -588,7 +588,7 @@ cont (find-template-result-types call cont template rtypes))))) -;;; Get the operands into TNs, make TN-Refs for them, and then call +;;; Get the operands into TNs, make TN-REFs for them, and then call ;;; the template emit function. (defun ir2-convert-template (call block) (declare (type combination call) (type ir2-block block)) @@ -831,12 +831,14 @@ ;;;; full call -;;; Given a function continuation FUN, return as values a TN holding -;;; the thing that we call and true if the thing is named (false if it -;;; is a function). There are two interesting non-named cases: -;;; -- Known to be a function, no check needed: return the -;;; continuation loc. -;;; -- Not known what it is. +;;; Given a function continuation FUN, return (VALUES TN-TO-CALL +;;; NAMED-P), where TN-TO-CALL is a TN holding the thing that we call +;;; NAMED-P is true if the thing is named (false if it is a function). +;;; +;;; There are two interesting non-named cases: +;;; -- We know it's a function. No check needed: return the +;;; continuation LOC. +;;; -- We don't know what it is. (defun fun-continuation-tn (node block cont) (declare (type continuation cont)) (let ((2cont (continuation-info cont))) @@ -862,7 +864,7 @@ (specifier-type 'function)) (values temp nil)))))))) -;;; Set up the args to Node in the current frame, and return a tn-ref +;;; Set up the args to NODE in the current frame, and return a TN-REF ;;; list for the passing locations. (defun move-tail-full-call-args (node block) (declare (type combination node) (type ir2-block block)) @@ -964,7 +966,7 @@ arg-locs nargs))))) (values)) -;;; stuff to check in CHECK-FULL-CALL +;;; stuff to check in PONDER-FULL-CALL ;;; ;;; There are some things which are intended always to be optimized ;;; away by DEFTRANSFORMs and such, and so never compiled into full @@ -977,7 +979,7 @@ ;;; 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. + ;; reported to cmucl-imp 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 @@ -985,7 +987,7 @@ data-vector-set data-vector-ref)) -;;; more stuff to check in CHECK-FULL-CALL +;;; more stuff to check in PONDER-FULL-CALL ;;; ;;; These came in handy when troubleshooting cold boot after making ;;; major changes in the package structure: various transforms and @@ -997,12 +999,15 @@ #!+sb-show (defvar *show-full-called-fnames-p* nil) #!+sb-show (defvar *full-called-fnames* (make-hash-table :test 'equal)) -;;; Do some checks on a full call: +;;; Do some checks (and store some notes relevant for future checks) +;;; on a full call: ;;; * Is this a full call to something we have reason to know should -;;; never be full called? +;;; never be full called? (Except as of sbcl-0.7.18 or so, we no +;;; longer try to ensure this behavior when *FAILURE-P* has already +;;; been detected.) ;;; * 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) +(defun ponder-full-call (node) (let* ((cont (basic-combination-fun node)) (fname (continuation-fun-name cont t))) (declare (type (or symbol cons) fname)) @@ -1022,10 +1027,16 @@ (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)) - (bug "full call to ~S" fname)) + ;; When illegal code is compiled, all sorts of perverse paths + ;; through the compiler can be taken, and it's much harder -- and + ;; probably pointless -- to guarantee that always-optimized-away + ;; functions are actually optimized away. Thus, we skip the check + ;; in that case. + (unless *failure-p* + (when (memq fname *always-optimized-away*) + (/show (policy node speed) (policy node safety)) + (/show (policy node compilation-speed)) + (bug "full call to ~S" fname))) (when (consp fname) (destructuring-bind (setf stem) fname @@ -1038,7 +1049,7 @@ ;;; multiple-values call. (defun ir2-convert-full-call (node block) (declare (type combination node) (type ir2-block block)) - (check-full-call node) + (ponder-full-call node) (let ((2cont (continuation-info (node-cont node)))) (cond ((node-tail-p node) (ir2-convert-tail-full-call node block)) @@ -1279,14 +1290,15 @@ (defoptimizer (values-list ir2-convert) ((list) node block) (let* ((cont (node-cont node)) (2cont (continuation-info cont))) - (when 2cont - (ecase (ir2-continuation-kind 2cont) - (:fixed (ir2-convert-full-call node block)) - (:unknown - (let ((locs (ir2-continuation-locs 2cont))) - (vop* values-list node block - ((continuation-tn node block list) nil) - ((reference-tn-list locs t))))))))) + (cond ((and 2cont + (eq (ir2-continuation-kind 2cont) :unknown)) + (let ((locs (ir2-continuation-locs 2cont))) + (vop* values-list node block + ((continuation-tn node block list) nil) + ((reference-tn-list locs t))))) + (t (aver (or (not 2cont) ; i.e. we want to check the argument + (eq (ir2-continuation-kind 2cont) :fixed))) + (ir2-convert-full-call node block))))) (defoptimizer (%more-arg-values ir2-convert) ((context start count) node block) (let* ((cont (node-cont node)) @@ -1370,6 +1382,7 @@ (defun ir2-convert-throw (node block) (declare (type mv-combination node) (type ir2-block block)) (let ((args (basic-combination-args node))) + (check-catch-tag-type (first args)) (vop* throw node block ((continuation-tn node block (first args)) (reference-tn-list @@ -1430,6 +1443,7 @@ ;;; Set up the unwind block for these guys. (defoptimizer (%catch ir2-convert) ((info-cont tag) node block) + (check-catch-tag-type tag) (emit-nlx-start node block (continuation-value info-cont) tag)) (defoptimizer (%unwind-protect ir2-convert) ((info-cont cleanup) node block) (emit-nlx-start node block (continuation-value info-cont) nil))