X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgtn.lisp;h=571d82c727fde1802c4c9406773a505ba6a94949;hb=b956ed4f9cef685d1b49be28dcd2aec1e082d994;hp=e508d22b16619c163be60deb0479e5ff0226a7a3;hpb=416152f084604094445a758ff399871132dff2bd;p=sbcl.git diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index e508d22..571d82c 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,7 +30,7 @@ (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 @@ -49,21 +49,20 @@ (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 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) @@ -71,17 +70,17 @@ (primitive-type (leaf-type thing)))) (nlx-info *backend-t-primitive-type*)))) (push (cons thing (make-normal-tn ptype)) - reversed-ir2-environment-alist))) + reversed-ir2-physenv-alist))) - (let ((res (make-ir2-environment - :environment (nreverse reversed-ir2-environment-alist) + (let ((res (make-ir2-physenv + :closure (nreverse reversed-ir2-physenv-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)))) + (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)) @@ -111,8 +110,8 @@ ;;; 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) @@ -132,17 +131,18 @@ ;;; 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)) (dolist (fun funs (let ((*compiler-error-context* (lambda-bind (first funs)))) - (compiler-note + (compiler-notify "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,7 +150,7 @@ (declare (ignore ignore)) (when (eq count :unknown) (let ((*compiler-error-context* (lambda-bind fun))) - (compiler-note + (compiler-notify "Return type not fixed values, so can't use known return ~ convention:~% ~S" (type-specifier rtype))) @@ -167,7 +167,8 @@ (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)) + (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 @@ -192,7 +193,7 @@ (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)) @@ -204,12 +205,12 @@ ;;; 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))