X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=43b213d073df80de63679a80d711055acc9f24a1;hb=02c9007b4ca5753406f60019f4fe5e5f8392541a;hp=d722ba5471973dffe834beba4d617c2b012237fd;hpb=1a7d93adc5e5fa3c1bfe09ebbe32f54db6c8abcc;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index d722ba5..43b213d 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 @@ -291,7 +291,7 @@ (cond ((and (eq (continuation-type-check cont) t) (multiple-value-bind (check types) - (continuation-check-types cont) + (continuation-check-types cont nil) (aver (eq check :simple)) ;; If the proven type is a subtype of the possibly ;; weakened type check then it's always true and is @@ -323,7 +323,7 @@ (nlocs (length locs))) (aver (= nlocs (length ptypes))) (if (eq (continuation-type-check cont) t) - (multiple-value-bind (check types) (continuation-check-types cont) + (multiple-value-bind (check types) (continuation-check-types cont nil) (aver (eq check :simple)) (let ((ntypes (length types))) (mapcar (lambda (from to-type assertion) @@ -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)) @@ -966,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 @@ -979,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 @@ -987,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 @@ -999,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)) @@ -1024,15 +1027,23 @@ (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 - (aver (eq setf 'setf)) - (setf (gethash stem *setf-assumed-fboundp*) t))))) + (destructuring-bind (setfoid &rest stem) fname + (aver (member setfoid + '(setf sb!pcl::class-predicate sb!pcl::slot-accessor))) + (when (eq setfoid 'setf) + (setf (gethash (car 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 @@ -1040,7 +1051,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)) @@ -1281,14 +1292,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)) @@ -1323,15 +1335,26 @@ (def-ir1-translator progv ((vars vals &body body) start cont) (ir1-convert start cont - (once-only ((n-save-bs '(%primitive current-binding-pointer))) - `(unwind-protect - (progn - (mapc (lambda (var val) - (%primitive bind val var)) - ,vars - ,vals) - ,@body) - (%primitive unbind-to-here ,n-save-bs))))) + (let ((bind (gensym "BIND")) + (unbind (gensym "UNBIND"))) + (once-only ((n-save-bs '(%primitive current-binding-pointer))) + `(unwind-protect + (progn + (labels ((,unbind (vars) + (declare (optimize (speed 2) (debug 0))) + (dolist (var vars) + (%primitive bind nil var) + (makunbound var))) + (,bind (vars vals) + (declare (optimize (speed 2) (debug 0))) + (cond ((null vars)) + ((null vals) (,unbind vars)) + (t (%primitive bind (car vals) (car vars)) + (,bind (cdr vars) (cdr vals)))))) + (,bind ,vars ,vals)) + nil + ,@body) + (%primitive unbind-to-here ,n-save-bs)))))) ;;;; non-local exit