X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgtn.lisp;h=af808d28f2c605a7567c60a4b99c144b59d52616;hb=8e4ec430504f0f563280be26034af590dff50d34;hp=6795bd247aa279f8b38ae2a2a55c4ee29c58a597;hpb=82e0a78df47685519b12683f495d7ae19e07d3cf;p=sbcl.git diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index 6795bd2..af808d2 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -20,187 +20,220 @@ (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) (dolist (let (lambda-lets fun)) - (assign-lambda-var-tns let t)))) + (assign-lambda-var-tns let t)))) (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)) (when (leaf-refs var) - (let* ((type (if (lambda-var-indirect var) - *backend-t-primitive-type* - (primitive-type (leaf-type var)))) - (temp (make-normal-tn type)) - (node (lambda-bind fun)) - (res (if (or (and let-p (policy node (< debug 3))) - (policy node (zerop debug)) - (policy node (= speed 3))) - temp - (environment-debug-live-tn temp - (lambda-environment fun))))) - (setf (tn-leaf res) var) - (setf (leaf-info var) res)))) + (let* (ptype-info + (type (if (lambda-var-indirect var) + (if (lambda-var-explicit-value-cell var) + *backend-t-primitive-type* + (or (first + (setf ptype-info + (primitive-type-indirect-cell-type + (primitive-type (leaf-type var))))) + *backend-t-primitive-type*)) + (primitive-type (leaf-type var)))) + (res (make-normal-tn type)) + (node (lambda-bind fun)) + (debug-variable-p (not (or (and let-p (policy node (< debug 3))) + (policy node (zerop debug)) + (policy node (= speed 3)))))) + (cond + ((and (lambda-var-indirect var) + (not (lambda-var-explicit-value-cell var))) + ;; Force closed-over indirect LAMBDA-VARs without explicit + ;; VALUE-CELLs to the stack, and make sure that they are + ;; live over the dynamic contour of the physenv. + (setf (tn-sc res) (if ptype-info + (second ptype-info) + (sc-or-lose 'sb!vm::control-stack))) + (physenv-live-tn res (lambda-physenv fun))) + + (debug-variable-p + (physenv-debug-live-tn res (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))))) - - (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))))) +;;; 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*) + (clambda *backend-t-primitive-type*)))) + (push (cons thing (make-normal-tn ptype)) + reversed-ir2-physenv-alist))) + + (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 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))) (and return - (do-uses (use (return-result return) nil) - (when (and (node-tail-p use) - (basic-combination-p use) - (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. + (do-uses (use (return-result return) nil) + (when (and (node-tail-p use) + (basic-combination-p use) + (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. +;;; -- We're compiling with RETURN-FROM-FRAME instrumentation, which +;;; only works (on x86 and x86-64) for the 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) - (find-if #'has-full-call-use funs)) - (block punt - (dolist (fun funs t) - (dolist (ref (leaf-refs fun)) - (let* ((cont (node-cont ref)) - (dest (continuation-dest cont))) - (when (and dest - (not (node-tail-p dest)) - (basic-combination-p dest) - (eq (basic-combination-fun dest) cont) - (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) + (let ((funs (tail-set-funs tails))) + (or (and (find-if #'xep-p funs) + (find-if #'has-full-call-use funs)) + (some (lambda (fun) (policy fun (>= insert-debug-catch 2))) funs) + (block punt + (dolist (fun funs t) + (dolist (ref (leaf-refs fun)) + (let* ((lvar (node-lvar ref)) + (dest (and lvar (lvar-dest lvar)))) + (when (and (basic-combination-p dest) + (not (node-tail-p dest)) + (eq (basic-combination-fun dest) lvar) + (eq (basic-combination-kind dest) :local)) + (return-from punt nil))))))))) + +;;; 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))))) - (let ((ret (lambda-return fun))) - (when ret - (let ((rtype (return-result-type ret))) - (multiple-value-bind (ignore count) (values-types rtype) - (declare (ignore ignore)) - (when (eq count :unknown) - (let ((*compiler-error-context* (lambda-bind fun))) - (compiler-note - "Return type not fixed values, so can't use known return ~ - convention:~% ~S" - (type-specifier rtype))) - (return))))))))) + (let ((*compiler-error-context* (lambda-bind (first funs)))) + (compiler-notify + "Return value count mismatch prevents known return ~ + from these functions:~ + ~{~% ~A~}" + (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))) + (multiple-value-bind (ignore count) (values-types rtype) + (declare (ignore ignore)) + (when (eq count :unknown) + (let ((*compiler-error-context* (lambda-bind fun))) + (compiler-notify + "Return type not fixed values, so can't use known return ~ + convention:~% ~S" + (type-specifier rtype))) + (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)) + (use-standard (use-standard-returns tails))) + (when (and (eq count :unknown) (not use-standard) + (not (eq (tail-set-type tails) *empty-type*))) + (return-value-efficiency-note tails)) (if (or (eq count :unknown) use-standard) - (make-return-info :kind :unknown - :count count - :types ptypes) - (make-return-info :kind :fixed - :count count - :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. + (make-return-info :kind :unknown + :count count + :types ptypes) + (make-return-info :kind :fixed + :count count + :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. (defun assign-return-locations (fun) (declare (type clambda fun)) (let* ((tails (lambda-tail-set fun)) - (returns (or (tail-set-info tails) - (setf (tail-set-info tails) - (return-info-for-set tails)))) - (return (lambda-return fun))) + (returns (or (tail-set-info tails) + (setf (tail-set-info tails) + (return-info-for-set tails)))) + (return (lambda-return fun))) (when (and return - (not (eq (return-info-kind returns) :unknown)) - (external-entry-point-p fun)) + (not (eq (return-info-kind returns) :unknown)) + (xep-p fun)) (do-uses (use (return-result return)) - (setf (node-tail-p use) nil)))) + (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))))) + (make-ir2-nlx-info + :home (when (member (cleanup-kind (nlx-info-cleanup nlx)) + '(:block :tagbody)) + (if (nlx-info-safe-p nlx) + (make-normal-tn *backend-t-primitive-type*) + (make-stack-pointer-tn))) + :save-sp (make-nlx-sp-tn physenv))))) (values))