X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=9bf0a584ccaf103e1958d4d269680100599b6433;hb=6a9bbe6f36179cee92001a1f9ed5ff38be512644;hp=aae4e2f169bd818e6edb676d99475149fbaff852;hpb=0c25cf1e8e49095969378ab356a5516f29d4c139;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index aae4e2f..9bf0a58 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -323,19 +323,21 @@ (when (block-start next) ; NEXT is not an END-OF-COMPONENT marker (cond ( ;; We cannot combine with a successor block if: (or - ;; The successor has more than one predecessor. + ;; the successor has more than one predecessor; (rest (block-pred next)) - ;; The successor is the current block (infinite loop). + ;; the successor is the current block (infinite loop); (eq next block) - ;; The next block has a different cleanup, and thus + ;; the next block has a different cleanup, and thus ;; we may want to insert cleanup code between the - ;; two blocks at some point. + ;; two blocks at some point; (not (eq (block-end-cleanup block) (block-start-cleanup next))) - ;; The next block has a different home lambda, and + ;; the next block has a different home lambda, and ;; thus the control transfer is a non-local exit. (not (eq (block-home-lambda block) - (block-home-lambda next)))) + (block-home-lambda next))) + ;; Stack analysis phase wants ENTRY to start a block. + (entry-p (block-start-node next))) nil) (t (join-blocks block next) @@ -389,8 +391,9 @@ (delete-ref node) (unlink-node node)) (combination - (let ((info (combination-kind node))) - (when (fun-info-p info) + (let ((kind (combination-kind node)) + (info (combination-fun-info node))) + (when (and (eq kind :known) (fun-info-p info)) (let ((attr (fun-info-attributes info))) (when (and (not (ir1-attributep attr call)) ;; ### For now, don't delete potentially @@ -637,23 +640,36 @@ (propagate-fun-change node) (maybe-terminate-block node nil)) (let ((args (basic-combination-args node)) - (kind (basic-combination-kind node))) - (case kind + (kind (basic-combination-kind node)) + (info (basic-combination-fun-info node))) + (ecase kind (:local (let ((fun (combination-lambda node))) (if (eq (functional-kind fun) :let) (propagate-let-args node fun) (propagate-local-call-args node fun)))) - ((:full :error) + (:error (dolist (arg args) (when arg (setf (lvar-reoptimize arg) nil)))) - (t + (:full + (dolist (arg args) + (when arg + (setf (lvar-reoptimize arg) nil))) + (when info + (let ((fun (fun-info-derive-type info))) + (when fun + (let ((res (funcall fun node))) + (when res + (derive-node-type node (coerce-to-values res)) + (maybe-terminate-block node nil))))))) + (:known + (aver info) (dolist (arg args) (when arg (setf (lvar-reoptimize arg) nil))) - (let ((attr (fun-info-attributes kind))) + (let ((attr (fun-info-attributes info))) (when (and (ir1-attributep attr foldable) ;; KLUDGE: The next test could be made more sensitive, ;; only suppressing constant-folding of functions with @@ -679,16 +695,16 @@ (constant-fold-call node) (return-from ir1-optimize-combination))) - (let ((fun (fun-info-derive-type kind))) + (let ((fun (fun-info-derive-type info))) (when fun (let ((res (funcall fun node))) (when res (derive-node-type node (coerce-to-values res)) (maybe-terminate-block node nil))))) - (let ((fun (fun-info-optimizer kind))) + (let ((fun (fun-info-optimizer info))) (unless (and fun (funcall fun node)) - (dolist (x (fun-info-transforms kind)) + (dolist (x (fun-info-transforms info)) #!+sb-show (when *show-transforms-p* (let* ((lvar (basic-combination-fun node)) @@ -724,6 +740,7 @@ (ctran (node-next node)) (tail (component-tail (block-component block))) (succ (first (block-succ block)))) + (declare (ignore lvar)) (unless (or (and (eq node (block-last block)) (eq succ tail)) (block-delete-p block)) (when (eq (node-derived-type node) *empty-type*) @@ -775,7 +792,11 @@ (defined-fun-inlinep leaf) :no-chance))) (cond - ((eq inlinep :notinline) (values nil nil)) + ((eq inlinep :notinline) + (let ((info (info :function :info (leaf-source-name leaf)))) + (when info + (setf (basic-combination-fun-info call) info)) + (values nil nil))) ((not (and (global-var-p leaf) (eq (global-var-kind leaf) :global-function))) (values leaf nil)) @@ -810,7 +831,10 @@ (t (let ((info (info :function :info (leaf-source-name leaf)))) (if info - (values leaf (setf (basic-combination-kind call) info)) + (values leaf + (progn + (setf (basic-combination-kind call) :known) + (setf (basic-combination-fun-info call) info))) (values leaf nil))))))) ;;; Check whether CALL satisfies TYPE. If so, apply the type to the @@ -829,7 +853,7 @@ (recognize-known-call call ir1-converting-not-optimizing-p)) ((valid-fun-use call type :argument-test #'always-subtypep - :result-test #'always-subtypep + :result-test nil ;; KLUDGE: Common Lisp is such a dynamic ;; language that all we can do here in ;; general is issue a STYLE-WARNING. It @@ -1168,7 +1192,8 @@ (() (null (rest sets)) :exit-if-null) (set-use (principal-lvar-use (set-value set))) (() (and (combination-p set-use) - (fun-info-p (combination-kind set-use)) + (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) @@ -1720,7 +1745,8 @@ (immediately-used-p value use)) (unless next-block (when ctran (ensure-block-start ctran)) - (setq next-block (first (block-succ (node-block cast))))) + (setq next-block (first (block-succ (node-block cast)))) + (ensure-block-start (node-prev cast))) (%delete-lvar-use use) (add-lvar-use use lvar) (unlink-blocks (node-block use) (node-block cast))