X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgtn.lisp;h=0aa7f2bfac4f889c85bde5e326f8bd8f7011706d;hb=b05f52060838600d14b5d8ad4604a61351dd7017;hp=6795bd247aa279f8b38ae2a2a55c4ee29c58a597;hpb=82e0a78df47685519b12683f495d7ae19e07d3cf;p=sbcl.git diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index 6795bd2..0aa7f2b 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -20,7 +20,7 @@ (setf (component-info component) (make-ir2-component)) (let ((funs (component-lambdas component))) (dolist (fun funs) - (assign-ir2-environment fun) + (assign-ir2-physenv fun) (assign-return-locations fun) (assign-ir2-nlx-info fun) (assign-lambda-var-tns fun nil) @@ -30,11 +30,12 @@ (values)) ;;; We have to allocate the home TNs for variables before we can call -;;; Assign-IR2-Environment so that we can close over TNs that haven't had their -;;; home environment assigned yet. Here we evaluate the DEBUG-INFO/SPEED -;;; tradeoff to determine how variables are allocated. If SPEED is 3, then all -;;; variables are subject to lifetime analysis. Otherwise, only Let-P variables -;;; are allocated normally, and that can be inhibited by DEBUG-INFO = 3. +;;; ASSIGN-IR2-PHYSENV so that we can close over TNs that haven't +;;; had their home environment assigned yet. Here we evaluate the +;;; DEBUG-INFO/SPEED tradeoff to determine how variables are +;;; allocated. If SPEED is 3, then all variables are subject to +;;; lifetime analysis. Otherwise, only LET-P variables are allocated +;;; normally, and that can be inhibited by DEBUG-INFO = 3. (defun assign-lambda-var-tns (fun let-p) (declare (type clambda fun)) (dolist (var (lambda-vars fun)) @@ -48,44 +49,47 @@ (policy node (zerop debug)) (policy node (= speed 3))) temp - (environment-debug-live-tn temp - (lambda-environment fun))))) + (physenv-debug-live-tn temp (lambda-physenv fun))))) (setf (tn-leaf res) var) (setf (leaf-info var) res)))) (values)) -;;; Give an IR2-Environment structure to Fun. We make the TNs which hold -;;; environment values and the old-FP/return-PC. -(defun assign-ir2-environment (fun) - (declare (type clambda fun)) - (let ((env (lambda-environment fun))) - (collect ((env)) - (dolist (thing (environment-closure env)) - (let ((ptype (etypecase thing - (lambda-var - (if (lambda-var-indirect thing) - *backend-t-primitive-type* - (primitive-type (leaf-type thing)))) - (nlx-info *backend-t-primitive-type*)))) - (env (cons thing (make-normal-tn ptype))))) +;;; Give CLAMBDA an IR2-PHYSENV structure. (And in order to +;;; properly initialize the new structure, we make the TNs which hold +;;; environment values and the old-FP/return-PC.) +(defun assign-ir2-physenv (clambda) + (declare (type clambda clambda)) + (let ((lambda-physenv (lambda-physenv clambda)) + (reversed-ir2-physenv-alist nil)) + ;; FIXME: should be MAPCAR, not DOLIST + (dolist (thing (physenv-closure lambda-physenv)) + (let ((ptype (etypecase thing + (lambda-var + (if (lambda-var-indirect thing) + *backend-t-primitive-type* + (primitive-type (leaf-type thing)))) + (nlx-info *backend-t-primitive-type*)))) + (push (cons thing (make-normal-tn ptype)) + reversed-ir2-physenv-alist))) - (let ((res (make-ir2-environment - :environment (env) - :return-pc-pass (make-return-pc-passing-location - (external-entry-point-p fun))))) - (setf (environment-info env) res) - (setf (ir2-environment-old-fp res) - (make-old-fp-save-location env)) - (setf (ir2-environment-return-pc res) - (make-return-pc-save-location env))))) + (let ((res (make-ir2-physenv + :closure (nreverse reversed-ir2-physenv-alist) + :return-pc-pass (make-return-pc-passing-location + (xep-p clambda))))) + (setf (physenv-info lambda-physenv) res) + (setf (ir2-physenv-old-fp res) + (make-old-fp-save-location lambda-physenv)) + (setf (ir2-physenv-return-pc res) + (make-return-pc-save-location lambda-physenv)))) (values)) -;;; Return true if Fun's result continuation is used in a TR full call. We -;;; only consider explicit :Full calls. It is assumed that known calls are -;;; never part of a tail-recursive loop, so we don't need to enforce -;;; tail-recursion. In any case, we don't know which known calls will -;;; actually be full calls until after LTN. +;;; Return true if FUN's result continuation is used in a +;;; tail-recursive full call. We only consider explicit :FULL calls. +;;; It is assumed that known calls are never part of a tail-recursive +;;; loop, so we don't need to enforce tail-recursion. In any case, we +;;; don't know which known calls will actually be full calls until +;;; after LTN. (defun has-full-call-use (fun) (declare (type clambda fun)) (let ((return (lambda-return fun))) @@ -96,17 +100,18 @@ (eq (basic-combination-kind use) :full)) (return t)))))) -;;; Return true if we should use the standard (unknown) return convention -;;; for a tail-set. We use the standard return convention when: -;;; -- We must use the standard convention to preserve tail-recursion, since -;;; the tail-set contains both an XEP and a TR full call. -;;; -- It appears to be more efficient to use the standard convention, since -;;; there are no non-TR local calls that could benefit from a non-standard -;;; convention. +;;; Return true if we should use the standard (unknown) return +;;; convention for a TAIL-SET. We use the standard return convention +;;; when: +;;; -- We must use the standard convention to preserve tail-recursion, +;;; since the TAIL-SET contains both an XEP and a TR full call. +;;; -- It appears to be more efficient to use the standard convention, +;;; since there are no non-TR local calls that could benefit from +;;; a non-standard convention. (defun use-standard-returns (tails) (declare (type tail-set tails)) - (let ((funs (tail-set-functions tails))) - (or (and (find-if #'external-entry-point-p funs) + (let ((funs (tail-set-funs tails))) + (or (and (find-if #'xep-p funs) (find-if #'has-full-call-use funs)) (block punt (dolist (fun funs t) @@ -120,22 +125,24 @@ (eq (basic-combination-kind dest) :local)) (return-from punt nil))))))))) -;;; If policy indicates, give an efficency note about our inability to use -;;; the known return convention. We try to find a function in the tail set -;;; with non-constant return values to use as context. If there is no such -;;; function, then be more vague. -(defun return-value-efficency-note (tails) +;;; If policy indicates, give an efficiency note about our inability to +;;; use the known return convention. We try to find a function in the +;;; tail set with non-constant return values to use as context. If +;;; there is no such function, then be more vague. +(defun return-value-efficiency-note (tails) (declare (type tail-set tails)) - (let ((funs (tail-set-functions tails))) - (when (policy (lambda-bind (first funs)) (> (max speed space) - inhibit-warnings)) + (let ((funs (tail-set-funs tails))) + (when (policy (lambda-bind (first funs)) + (> (max speed space) + inhibit-warnings)) (dolist (fun funs (let ((*compiler-error-context* (lambda-bind (first funs)))) (compiler-note "Return value count mismatch prevents known return ~ from these functions:~ ~{~% ~A~}" - (remove nil (mapcar #'leaf-name funs))))) + (mapcar #'leaf-source-name + (remove-if-not #'leaf-has-source-name-p funs))))) (let ((ret (lambda-return fun))) (when ret (let ((rtype (return-result-type ret))) @@ -150,18 +157,18 @@ (return))))))))) (values)) -;;; Return a Return-Info structure describing how we should return from -;;; functions in the specified tail set. We use the unknown values convention -;;; if the number of values is unknown, or if it is a good idea for some other -;;; reason. Otherwise we allocate passing locations for a fixed number of -;;; values. +;;; Return a RETURN-INFO structure describing how we should return +;;; from functions in the specified tail set. We use the unknown +;;; values convention if the number of values is unknown, or if it is +;;; a good idea for some other reason. Otherwise we allocate passing +;;; locations for a fixed number of values. (defun return-info-for-set (tails) (declare (type tail-set tails)) (multiple-value-bind (types count) (values-types (tail-set-type tails)) (let ((ptypes (mapcar #'primitive-type types)) (use-standard (use-standard-returns tails))) (when (and (eq count :unknown) (not use-standard)) - (return-value-efficency-note tails)) + (return-value-efficiency-note tails)) (if (or (eq count :unknown) use-standard) (make-return-info :kind :unknown :count count @@ -171,10 +178,11 @@ :types ptypes :locations (mapcar #'make-normal-tn ptypes)))))) -;;; If Tail-Set doesn't have any Info, then make a Return-Info for it. If -;;; we choose a return convention other than :Unknown, and this environment is -;;; for an XEP, then break tail recursion on the XEP calls, since we must -;;; always use unknown values when returning from an XEP. +;;; If TAIL-SET doesn't have any INFO, then make a RETURN-INFO for it. +;;; If we choose a return convention other than :UNKNOWN, and this +;;; environment is for an XEP, then break tail recursion on the XEP +;;; calls, since we must always use unknown values when returning from +;;; an XEP. (defun assign-return-locations (fun) (declare (type clambda fun)) (let* ((tails (lambda-tail-set fun)) @@ -184,23 +192,24 @@ (return (lambda-return fun))) (when (and return (not (eq (return-info-kind returns) :unknown)) - (external-entry-point-p fun)) + (xep-p fun)) (do-uses (use (return-result return)) (setf (node-tail-p use) nil)))) (values)) -;;; Make an IR2-NLX-Info structure for each NLX entry point recorded. We -;;; call a VM supplied function to make the Save-SP restricted on the stack. -;;; The NLX-Entry VOP's :Force-To-Stack Save-P value doesn't do this, since the -;;; SP is an argument to the VOP, and thus isn't live afterwards. +;;; Make an IR2-NLX-INFO structure for each NLX entry point recorded. +;;; We call a VM supplied function to make the SAVE-SP restricted on +;;; the stack. The NLX-ENTRY VOP's :FORCE-TO-STACK SAVE-P value +;;; doesn't do this, since the SP is an argument to the VOP, and thus +;;; isn't live afterwards. (defun assign-ir2-nlx-info (fun) (declare (type clambda fun)) - (let ((env (lambda-environment fun))) - (dolist (nlx (environment-nlx-info env)) + (let ((physenv (lambda-physenv fun))) + (dolist (nlx (physenv-nlx-info physenv)) (setf (nlx-info-info nlx) (make-ir2-nlx-info :home (when (member (cleanup-kind (nlx-info-cleanup nlx)) '(:block :tagbody)) (make-normal-tn *backend-t-primitive-type*)) - :save-sp (make-nlx-sp-tn env))))) + :save-sp (make-nlx-sp-tn physenv))))) (values))