(not (eq (block-home-lambda block)
(block-home-lambda next)))
;; Stack analysis phase wants ENTRY to start a block.
- (entry-p (block-start-node next)))
+ (entry-p (block-start-node next))
+ (let ((last (block-last block)))
+ (and (valued-node-p last)
+ (awhen (node-lvar last)
+ (consp (lvar-uses it))))))
nil)
(t
(join-blocks block next)
(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
(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
(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))
(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*)
(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))
(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
(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
(lvar-uses (basic-combination-fun call))
call))
((not leaf))
- ((and (leaf-has-source-name-p leaf)
+ ((and (global-var-p leaf)
+ (eq (global-var-kind leaf) :global-function)
+ (leaf-has-source-name-p leaf)
(or (info :function :source-transform (leaf-source-name leaf))
(and info
(ir1-attributep (fun-info-attributes info)
(:aborted
(setf (combination-kind node) :error)
(when args
- (apply #'compiler-warn args))
+ (apply #'warn args))
(remhash node table)
nil)
(:failure
(block-next (node-block call)))
(let ((new-fun (ir1-convert-inline-lambda
res
- :debug-name (debug-namify "LAMBDA-inlined ~A"
- (as-debug-name
- source-name
- "<unknown function>"))))
+ :debug-name (debug-namify "LAMBDA-inlined "
+ source-name
+ "<unknown function>")))
(ref (lvar-use (combination-fun call))))
(change-ref-leaf ref new-fun)
(setf (combination-kind call) :full)
(() (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)
(unless next-block
(when ctran (ensure-block-start ctran))
(setq next-block (first (block-succ (node-block cast))))
- (ensure-block-start (node-prev cast)))
+ (ensure-block-start (node-prev cast))
+ (reoptimize-lvar lvar)
+ (setf (lvar-%derived-type value) nil))
(%delete-lvar-use use)
(add-lvar-use use lvar)
(unlink-blocks (node-block use) (node-block cast))
;; FIXME: Do it in one step.
(filter-lvar
value
- `(multiple-value-call #'list 'dummy))
+ (if (cast-single-value-p cast)
+ `(list 'dummy)
+ `(multiple-value-call #'list 'dummy)))
(filter-lvar
(cast-value cast)
;; FIXME: Derived type.