X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgtn.lisp;h=af808d28f2c605a7567c60a4b99c144b59d52616;hb=12b1dae1a1ed90c6ffe4d958f1281c1c04a8e89b;hp=e508d22b16619c163be60deb0479e5ff0226a7a3;hpb=416152f084604094445a758ff399871132dff2bd;p=sbcl.git diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index e508d22..af808d2 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -20,17 +20,17 @@ (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 +;;; 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 @@ -40,66 +40,84 @@ (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 CLAMBDA an IR2-ENVIRONMENT structure. (And in order to +;;; 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-environment (clambda) +(defun assign-ir2-physenv (clambda) (declare (type clambda clambda)) - (let ((lambda-environment (lambda-environment clambda)) - (reversed-ir2-environment-alist nil)) + (let ((lambda-physenv (lambda-physenv clambda)) + (reversed-ir2-physenv-alist nil)) ;; FIXME: should be MAPCAR, not DOLIST - (dolist (thing (environment-closure lambda-environment)) + (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-environment-alist))) - - (let ((res (make-ir2-environment - :environment (nreverse reversed-ir2-environment-alist) - :return-pc-pass (make-return-pc-passing-location - (external-entry-point-p clambda))))) - (setf (environment-info lambda-environment) res) - (setf (ir2-environment-old-fp res) - (make-old-fp-save-location lambda-environment)) - (setf (ir2-environment-return-pc res) - (make-return-pc-save-location lambda-environment)))) + (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 -;;; 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. +;;; 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)))))) + (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 @@ -109,22 +127,24 @@ ;;; -- 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))))))))) + (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 @@ -132,29 +152,30 @@ ;;; 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))) + (let ((funs (tail-set-funs tails))) (when (policy (lambda-bind (first funs)) - (> (max speed space) - inhibit-warnings)) + (> (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 @@ -166,17 +187,18 @@ (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-efficiency-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)))))) + (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 @@ -186,15 +208,15 @@ (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. @@ -204,12 +226,14 @@ ;;; 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))