(values-type-union (node-derived-type (first current))
res))
(current (rest uses) (rest current)))
- ((null current) res)))
+ ((or (null current) (eq res *wild-type*))
+ res)))
(t
- (node-derived-type (lvar-uses lvar))))))
+ (node-derived-type uses)))))
;;; Return the derived type for LVAR's first value. This is guaranteed
;;; not to be a VALUES or FUNCTION type.
(lambda-var-p (ref-leaf node)))
(let ((type (single-value-type int)))
(when (and (member-type-p type)
- (null (rest (member-type-members type))))
+ (eql 1 (member-type-size type)))
(change-ref-leaf node (find-constant
(first (member-type-members type)))))))
(reoptimize-lvar lvar)))))
;;; 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.
(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))
;; 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
(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)
*policy*)))
(setf (cast-type-to-check cast) *wild-type*)
(substitute-lvar-uses value arg
- ;; FIXME
- t)
+ ;; FIXME
+ t)
(%delete-lvar-use ref)
(add-lvar-use cast lvar)))))
(setf (node-derived-type ref) *wild-type*)
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))))))
;;; right here.
(defun propagate-local-call-args (call fun)
(declare (type combination call) (type clambda fun))
-
(unless (or (functional-entry-fun fun)
(lambda-optional-dispatch fun))
(let* ((vars (lambda-vars fun))
;;; 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))
(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))
projects / sbcl.git / blobdiff