X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=2c53ed4dd699e531d2aebd6f70dda17e5cc8fd3d;hb=872175cd9cb5b4966a36d4bd92421cc407a0355b;hp=0c8e6960f5cada4338d85168c2c833284a1542c4;hpb=212ef8043aeaceaa627f2924e04554fbc37b8ee1;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 0c8e696..2c53ed4 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) @@ -476,7 +476,7 @@ (declare (type combination call) (type continuation cont) (type template template) (list rtypes)) (let* ((dtype (node-derived-type call)) - (type (if (and (or (eq (template-policy template) :safe) + (type (if (and (or (eq (template-ltn-policy template) :safe) (policy call (= safety 0))) (continuation-type-check cont)) (values-type-intersection @@ -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)))))))) @@ -904,6 +904,29 @@ 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 @@ -914,13 +937,12 @@ #!+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)) @@ -930,6 +952,8 @@ #!+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 @@ -938,11 +962,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)) + (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)) @@ -951,7 +987,6 @@ (ir2-convert-multiple-full-call node block)) (t (ir2-convert-fixed-full-call node block)))) - (values)) ;;;; entering functions @@ -1015,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) @@ -1078,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)) @@ -1109,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))) @@ -1130,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) @@ -1139,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)))) @@ -1162,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))))) @@ -1217,14 +1252,14 @@ (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 @@ -1405,7 +1440,7 @@ ;;;; 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)) @@ -1415,8 +1450,8 @@ (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*)) ;;;; structure accessors ;;;; @@ -1506,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) @@ -1522,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)))))))