X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=2bdb4dedd65aaab3ac4456f6e19f88f3d3505304;hb=bd455348d39bee562296741689882dcb97c46ba3;hp=f2152d36ad3eedd6bbcebdb9d059aa364d17149e;hpb=151d241aa79f2346ae18d179255fc6b5a2013229;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index f2152d3..2bdb4de 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -724,17 +724,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)) @@ -837,11 +850,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 @@ -1104,10 +1121,22 @@ (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) + ;; 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). + (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))))) (locall-analyze-component *current-component*)))) (values)) @@ -1226,20 +1255,28 @@ (eq (combination-kind set-use) :known) (fun-info-p (combination-fun-info set-use)) (not (node-to-be-deleted-p set-use)) - (eq (combination-fun-source-name set-use) '+)) - :exit-if-null) + (or (eq (combination-fun-source-name set-use) '+) + (eq (combination-fun-source-name set-use) '-))) + :exit-if-null) + (minusp (eq (combination-fun-source-name set-use) '-)) (+-args (basic-combination-args set-use)) (() (and (proper-list-of-length-p +-args 2 2) (let ((first (principal-lvar-use (first +-args)))) (and (ref-p first) (eq (ref-leaf first) var)))) - :exit-if-null) + :exit-if-null) (step-type (lvar-type (second +-args))) (set-type (lvar-type (set-value set)))) (when (and (numeric-type-p initial-type) (numeric-type-p step-type) - (numeric-type-equal initial-type step-type)) + (or (numeric-type-equal initial-type step-type) + ;; Detect cases like (LOOP FOR 1.0 to 5.0 ...), where + ;; the initial and the step are of different types, + ;; and the step is less contagious. + (numeric-type-equal initial-type + (numeric-contagion initial-type + step-type)))) (labels ((leftmost (x y cmp cmp=) (cond ((eq x nil) nil) ((eq y nil) nil) @@ -1256,22 +1293,27 @@ (t (if (funcall cmp x y) x y)))) (max* (x y) (leftmost x y #'> #'>=)) (min* (x y) (leftmost x y #'< #'<=))) - (declare (inline compare)) (multiple-value-bind (low high) - (cond ((csubtypep step-type (specifier-type '(real 0 *))) - (values (numeric-type-low initial-type) - (when (and (numeric-type-p set-type) - (numeric-type-equal set-type initial-type)) - (max* (numeric-type-high initial-type) - (numeric-type-high set-type))))) - ((csubtypep step-type (specifier-type '(real * 0))) - (values (when (and (numeric-type-p set-type) - (numeric-type-equal set-type initial-type)) - (min* (numeric-type-low initial-type) - (numeric-type-low set-type))) - (numeric-type-high initial-type))) - (t - (values nil nil))) + (let ((step-type-non-negative (csubtypep step-type (specifier-type + '(real 0 *)))) + (step-type-non-positive (csubtypep step-type (specifier-type + '(real * 0))))) + (cond ((or (and step-type-non-negative (not minusp)) + (and step-type-non-positive minusp)) + (values (numeric-type-low initial-type) + (when (and (numeric-type-p set-type) + (numeric-type-equal set-type initial-type)) + (max* (numeric-type-high initial-type) + (numeric-type-high set-type))))) + ((or (and step-type-non-positive (not minusp)) + (and step-type-non-negative minusp)) + (values (when (and (numeric-type-p set-type) + (numeric-type-equal set-type initial-type)) + (min* (numeric-type-low initial-type) + (numeric-type-low set-type))) + (numeric-type-high initial-type))) + (t + (values nil nil)))) (modified-numeric-type initial-type :low low :high high @@ -1474,6 +1516,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)))))) @@ -1866,3 +1911,6 @@ (unless do-not-optimize (setf (node-reoptimize cast) nil))) + +(deftransform make-symbol ((string) (simple-string)) + `(%make-symbol string))