X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=78ae5a8d21fd0a9fd516151a4e7b3db21b5f207f;hb=66cff1e1319861c080d563359afea284614b3a7f;hp=df05a08eb90ea1fa3bfd9e8a61377b7e8837fbb4;hpb=62b6c13eaaefa20b790e10a28d292e1821cd4446;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index df05a08..78ae5a8 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -451,7 +451,7 @@ ;;; appropriate.) ;;; ;;; We call MAYBE-CONVERT-TAIL-LOCAL-CALL on each local non-MV -;;; combination, which may change the succesor of the call to be the +;;; combination, which may change the successor of the call to be the ;;; called function, and if so, checks if the call can become an ;;; assignment. If we convert to an assignment, we abort, since the ;;; RETURN has been deleted. @@ -693,7 +693,10 @@ (setf (lvar-reoptimize arg) nil))) (check-important-result node info) (let ((fun (fun-info-destroyed-constant-args info))) - (when fun + (when (and fun + ;; If somebody is really sure that they want to modify + ;; constants, let them. + (policy node (> safety 0))) (let ((destroyed-constant-args (funcall fun args))) (when destroyed-constant-args (let ((*compiler-error-context* node)) @@ -724,17 +727,30 @@ (let ((fun (fun-info-optimizer info))) (unless (and fun (funcall fun node)) - (dolist (x (fun-info-transforms info)) - #!+sb-show - (when *show-transforms-p* - (let* ((lvar (basic-combination-fun node)) - (fname (lvar-fun-name lvar t))) - (/show "trying transform" x (transform-function x) "for" fname))) - (unless (ir1-transform node x) - #!+sb-show - (when *show-transforms-p* - (/show "quitting because IR1-TRANSFORM result was NIL")) - (return)))))))) + ;; First give the VM a peek at the call + (multiple-value-bind (style transform) + (combination-implementation-style node) + (ecase style + (:direct + ;; The VM knows how to handle this. + ) + (:transform + ;; The VM mostly knows how to handle this. We need + ;; to massage the call slightly, though. + (transform-call node transform (combination-fun-source-name node))) + (:default + ;; Let transforms have a crack at it. + (dolist (x (fun-info-transforms info)) + #!+sb-show + (when *show-transforms-p* + (let* ((lvar (basic-combination-fun node)) + (fname (lvar-fun-name lvar t))) + (/show "trying transform" x (transform-function x) "for" fname))) + (unless (ir1-transform node x) + #!+sb-show + (when *show-transforms-p* + (/show "quitting because IR1-TRANSFORM result was NIL")) + (return))))))))))) (values)) @@ -827,6 +843,12 @@ (:inline t) (:no-chance nil) ((nil :maybe-inline) (policy call (zerop space)))) + ;; FIXME & KLUDGE: This LET-CONVERSION check was added as a + ;; half-assed workaround for the bug for which the test + ;; case :HIGH-DEBUG-KNOWN-FUNCTION-INLINING checks in + ;; compiler.pure.lisp. The _real_ culprit seems to be + ;; the insertion of BIND/UNBIND-SENTINEL vops. + (policy call (plusp let-conversion)) (defined-fun-p leaf) (defined-fun-inline-expansion leaf) (let ((fun (defined-fun-functional leaf))) @@ -837,11 +859,15 @@ ;; called semi-inlining? A more descriptive name would ;; be nice. -- WHN 2002-01-07 (frob () - (let ((res (let ((*allow-instrumenting* t)) - (ir1-convert-lambda-for-defun - (defined-fun-inline-expansion leaf) - leaf t - #'ir1-convert-inline-lambda)))) + (let* ((name (leaf-source-name leaf)) + (res (ir1-convert-inline-expansion + name + (defined-fun-inline-expansion leaf) + leaf + inlinep + (info :function :info name)))) + ;; allow backward references to this function from + ;; following top level forms (setf (defined-fun-functional leaf) res) (change-ref-leaf ref res)))) (if ir1-converting-not-optimizing-p @@ -1099,12 +1125,28 @@ (aver (and (legal-fun-name-p source-name) (not (eql source-name '.anonymous.)))) (node-ends-block call) + ;; The internal variables of a transform are not going to be + ;; interesting to the debugger, so there's no sense in + ;; suppressing the substitution of variables with only one use + ;; (the extra variables can slow down constraint propagation). + ;; + ;; This needs to be done before the WITH-IR1-ENVIRONMENT-FROM-NODE, + ;; so that it will bind *LEXENV* to the right environment. + (setf (combination-lexenv call) + (make-lexenv :default (combination-lexenv call) + :policy (process-optimize-decl + '(optimize + (preserve-single-use-debug-variables 0)) + (lexenv-policy + (combination-lexenv call))))) (with-ir1-environment-from-node call (with-component-last-block (*current-component* (block-next (node-block call))) + (let ((new-fun (ir1-convert-inline-lambda res - :debug-name (debug-name 'lambda-inlined source-name))) + :debug-name (debug-name 'lambda-inlined source-name) + :system-lambda t)) (ref (lvar-use (combination-fun call)))) (change-ref-leaf ref new-fun) (setf (combination-kind call) :full) @@ -1487,6 +1529,9 @@ leaf var))) t))))) ((and (null (rest (leaf-refs var))) + ;; Don't substitute single-ref variables on high-debug / + ;; low speed, to improve the debugging experience. + (policy call (< preserve-single-use-debug-variables 3)) (substitute-single-use-lvar arg var))) (t (propagate-to-refs var (lvar-type arg)))))) @@ -1798,6 +1843,17 @@ ;;; TODO: ;;; - CAST chains; +(defun delete-cast (cast) + (declare (type cast cast)) + (let ((value (cast-value cast)) + (lvar (node-lvar cast))) + (delete-filter cast lvar value) + (when lvar + (reoptimize-lvar lvar) + (when (lvar-single-value-p lvar) + (note-single-valuified-lvar lvar))) + (values))) + (defun ir1-optimize-cast (cast &optional do-not-optimize) (declare (type cast cast)) (let ((value (cast-value cast)) @@ -1806,11 +1862,7 @@ (let ((lvar (node-lvar cast))) (when (values-subtypep (lvar-derived-type value) (cast-asserted-type cast)) - (delete-filter cast lvar value) - (when lvar - (reoptimize-lvar lvar) - (when (lvar-single-value-p lvar) - (note-single-valuified-lvar lvar))) + (delete-cast cast) (return-from ir1-optimize-cast t)) (when (and (listp (lvar-uses value))