;;;; DYNAMIC-EXTENT related
+(defun lambda-var-original-name (leaf)
+ (let ((home (lambda-var-home leaf)))
+ (if (eq :external (functional-kind home))
+ (let* ((entry (functional-entry-fun home))
+ (p (1- (position leaf (lambda-vars home)))))
+ (leaf-debug-name
+ (if (optional-dispatch-p entry)
+ (elt (optional-dispatch-arglist entry) p)
+ (elt (lambda-vars entry) p))))
+ (leaf-debug-name leaf))))
+
(defun note-no-stack-allocation (lvar &key flush)
(do-uses (use (principal-lvar lvar))
(unless (or
;; Don't complain about not being able to stack allocate constants.
(and (ref-p use) (constant-p (ref-leaf use)))
;; If we're flushing, don't complain if we can flush the combination.
- (and flush (combination-p use) (flushable-combination-p use)))
+ (and flush (combination-p use) (flushable-combination-p use))
+ ;; Don't report those with homes in :OPTIONAL -- we'd get doubled
+ ;; reports that way.
+ (and (ref-p use) (lambda-var-p (ref-leaf use))
+ (eq :optional (lambda-kind (lambda-var-home (ref-leaf use))))))
+ ;; FIXME: For the first leg (lambda-bind (lambda-var-home ...))
+ ;; would be a far better description, but since we use
+ ;; *COMPILER-ERROR-CONTEXT* for muffling we can't -- as that node
+ ;; can have different handled conditions.
(let ((*compiler-error-context* use))
- (compiler-notify "could not stack allocate the result of ~S"
- (find-original-source (node-source-path use)))))))
+ (if (and (ref-p use) (lambda-var-p (ref-leaf use)))
+ (compiler-notify "~@<could~2:I not stack allocate ~S in: ~S~:@>"
+ (lambda-var-original-name (ref-leaf use))
+ (find-original-source (node-source-path use)))
+ (compiler-notify "~@<could~2:I not stack allocate: ~S~:@>"
+ (find-original-source (node-source-path use))))))))
(defun use-good-for-dx-p (use dx &optional component)
;; FIXME: Can casts point to LVARs in other components?
(return-from combination-args-flow-cleanly-p nil)))))))))))
(recurse combination1)))
+(defun ref-good-for-dx-p (ref)
+ (let* ((lvar (ref-lvar ref))
+ (dest (when lvar (lvar-dest lvar))))
+ (and (combination-p dest)
+ (eq :known (combination-kind dest))
+ (awhen (combination-fun-info dest)
+ (or (ir1-attributep (fun-info-attributes it) dx-safe)
+ (and (not (combination-lvar dest))
+ (awhen (fun-info-result-arg it)
+ (eql lvar (nth it (combination-args dest))))))))))
+
(defun trivial-lambda-var-ref-p (use)
(and (ref-p use)
(let ((var (ref-leaf use)))
(neq :indefinite (lambda-var-extent var)))
(let ((home (lambda-var-home var))
(refs (lambda-var-refs var)))
- ;; bound by a system lambda, no other REFS
+ ;; bound by a non-XEP system lambda, no other REFS that aren't
+ ;; DX-SAFE, or are result-args when the result is discarded.
(when (and (lambda-system-lambda-p home)
- (eq use (car refs)) (not (cdr refs)))
+ (neq :external (lambda-kind home))
+ (dolist (ref refs t)
+ (unless (or (eq use ref) (ref-good-for-dx-p ref))
+ (return nil))))
;; the LAMBDA this var is bound by has only a single REF, going
;; to a combination
(let* ((lambda-refs (lambda-refs home))
(defun trivial-lambda-var-ref-lvar (use)
(let* ((this (ref-leaf use))
- (home (lambda-var-home this)))
- (multiple-value-bind (fun vars)
- (values home (lambda-vars home))
- (let* ((combination (lvar-dest (ref-lvar (car (lambda-refs fun)))))
- (args (combination-args combination)))
- (assert (= (length vars) (length args)))
- (loop for var in vars
- for arg in args
- when (eq var this)
- return arg)))))
+ (fun (lambda-var-home this))
+ (vars (lambda-vars fun))
+ (combination (lvar-dest (ref-lvar (car (lambda-refs fun)))))
+ (args (combination-args combination)))
+ (aver (= (length vars) (length args)))
+ (loop for var in vars
+ for arg in args
+ when (eq var this)
+ return arg)))
;;; This needs to play nice with LVAR-GOOD-FOR-DX-P and friends.
(defun handle-nested-dynamic-extent-lvars (dx lvar &optional recheck-component)
dx arg recheck-component)))
(ref
(let* ((other (trivial-lambda-var-ref-lvar use)))
- (print (list :ref use other))
(unless (eq other lvar)
(handle-nested-dynamic-extent-lvars
dx other recheck-component)))))))
(reoptimize-lvar prev)))
\f
;;; Return a new LEXENV just like DEFAULT except for the specified
-;;; slot values. Values for the alist slots are NCONCed to the
+;;; slot values. Values for the alist slots are APPENDed to the
;;; beginning of the current value, rather than replacing it entirely.
(defun make-lexenv (&key (default *lexenv*)
funs vars blocks tags
(macrolet ((frob (var slot)
`(let ((old (,slot default)))
(if ,var
- (nconc ,var old)
+ (append ,var old)
old))))
(internal-make-lexenv
(frob funs lexenv-funs)
projects / sbcl.git / blobdiff