(let ((*compiler-error-context* node))
(compiler-warn
"New inferred type ~S conflicts with old type:~
- ~% ~S~%*** possible internal error? Please report this."
+ ~% ~S~%*** possible internal error? Please report this."
(type-specifier rtype) (type-specifier node-type))))
(setf (node-derived-type node) int)
;; If the new type consists of only one object, replace the
(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))
+ (let ((last (block-last block)))
+ (and (valued-node-p last)
+ (awhen (node-lvar last)
+ (or
+ ;; ... and a DX-allocator to end a block.
+ (lvar-dynamic-extent it)
+ ;; FIXME: This is a partial workaround for bug 303.
+ (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))
;; called semi-inlining? A more descriptive name would
;; be nice. -- WHN 2002-01-07
(frob ()
- (let ((res (ir1-convert-lambda-for-defun
- (defined-fun-inline-expansion leaf)
- leaf t
- #'ir1-convert-inline-lambda)))
+ (let ((res (let ((*allow-instrumenting* t))
+ (ir1-convert-lambda-for-defun
+ (defined-fun-inline-expansion leaf)
+ leaf t
+ #'ir1-convert-inline-lambda))))
(setf (defined-fun-functional leaf) res)
(change-ref-leaf ref res))))
(if ir1-converting-not-optimizing-p
(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)
(dest (lvar-dest lvar)))
(when (and
;; Think about (LET ((A ...)) (IF ... A ...)): two
- ;; LVAR-USEs should not be met on one path.
+ ;; LVAR-USEs should not be met on one path. Another problem
+ ;; is with dynamic-extent.
(eq (lvar-uses lvar) ref)
(typecase dest
;; we should not change lifetime of unknown values lvars
(eq (node-home-lambda ref)
(lambda-home (lambda-var-home var))))
(setf (node-derived-type ref) *wild-type*)
- (substitute-lvar-uses lvar arg)
+ (substitute-lvar-uses lvar arg
+ ;; Really it is (EQ (LVAR-USES LVAR) REF):
+ t)
(delete-lvar-use ref)
(change-ref-leaf ref (find-constant nil))
(delete-ref ref)
(when (and min (< total-nvals min))
(compiler-warn
"MULTIPLE-VALUE-CALL with ~R values when the function expects ~
- at least ~R."
+ at least ~R."
total-nvals min)
(setf (basic-combination-kind node) :error)
(return-from ir1-optimize-mv-call))
(when (and max (> total-nvals max))
(compiler-warn
"MULTIPLE-VALUE-CALL with ~R values when the function expects ~
- at most ~R."
+ at most ~R."
total-nvals max)
(setf (basic-combination-kind node) :error)
(return-from ir1-optimize-mv-call)))
(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))
+ (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.
projects / sbcl.git / blobdiff