X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=f57786195df5e3bc9ac178fa4e3df2bc1673c1d1;hb=e2b33e0d99f0f93263defcd2e0dffe20c4e388f3;hp=cffa2e6454584c2be3d6610feaccc4017dee615f;hpb=5ec8d0c1c8b7939818b75118b472fac1af554f9a;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index cffa2e6..f577861 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -254,8 +254,16 @@ #!-sb-fluid (declare (inline node-home-lambda)) (the physenv (lambda-physenv (node-home-lambda node)))) -;;; Return the enclosing cleanup for environment of the first or last node -;;; in BLOCK. +#!-sb-fluid (declaim (maybe-inline lambda-block)) +(defun lambda-block (clambda) + (declare (type clambda clambda)) + (node-block (lambda-bind clambda))) +(defun lambda-component (clambda) + (declare (inline lambda-block)) + (block-component (lambda-block clambda))) + +;;; Return the enclosing cleanup for environment of the first or last +;;; node in BLOCK. (defun block-start-cleanup (block) (declare (type cblock block)) (node-enclosing-cleanup (continuation-next (block-start block)))) @@ -559,7 +567,7 @@ ;;; DELETE-REF will handle the deletion. (defun delete-functional (fun) (aver (and (null (leaf-refs fun)) - (not (functional-entry-function fun)))) + (not (functional-entry-fun fun)))) (etypecase fun (optional-dispatch (delete-optional-dispatch fun)) (clambda (delete-lambda fun))) @@ -578,8 +586,8 @@ ;;; (it won't be there before local call analysis, but no matter.) If ;;; the lambda was never referenced, we give a note. ;;; -;;; If the lambda is an XEP, then we null out the ENTRY-FUNCTION in its -;;; ENTRY-FUNCTION so that people will know that it is not an entry point +;;; If the lambda is an XEP, then we null out the ENTRY-FUN in its +;;; ENTRY-FUN so that people will know that it is not an entry point ;;; anymore. (defun delete-lambda (leaf) (declare (type clambda leaf)) @@ -603,21 +611,21 @@ (unless (leaf-ever-used leaf) (let ((*compiler-error-context* bind)) (compiler-note "deleting unused function~:[.~;~:*~% ~S~]" - (leaf-name leaf)))) + (leaf-debug-name leaf)))) (unlink-blocks (component-head component) bind-block) (when return (unlink-blocks (node-block return) (component-tail component))) (setf (component-reanalyze component) t) (let ((tails (lambda-tail-set leaf))) - (setf (tail-set-functions tails) - (delete leaf (tail-set-functions tails))) + (setf (tail-set-funs tails) + (delete leaf (tail-set-funs tails))) (setf (lambda-tail-set leaf) nil)) (setf (component-lambdas component) (delete leaf (component-lambdas component))))) (when (eq kind :external) - (let ((fun (functional-entry-function leaf))) - (setf (functional-entry-function fun) nil) + (let ((fun (functional-entry-fun leaf))) + (setf (functional-entry-fun fun) nil) (when (optional-dispatch-p fun) (delete-optional-dispatch fun))))) @@ -643,7 +651,7 @@ ;;; or even converted to a let. (defun delete-optional-dispatch (leaf) (declare (type optional-dispatch leaf)) - (let ((entry (functional-entry-function leaf))) + (let ((entry (functional-entry-fun leaf))) (unless (and entry (leaf-refs entry)) (aver (or (not entry) (eq (functional-kind entry) :deleted))) (setf (functional-kind leaf) :deleted) @@ -686,7 +694,7 @@ (clambda (ecase (functional-kind leaf) ((nil :let :mv-let :assignment :escape :cleanup) - (aver (not (functional-entry-function leaf))) + (aver (not (functional-entry-fun leaf))) (delete-lambda leaf)) (:external (delete-lambda leaf)) @@ -882,10 +890,10 @@ (let ((*compiler-error-context* (lambda-bind fun))) (unless (policy *compiler-error-context* (= inhibit-warnings 3)) ;; ANSI section "3.2.5 Exceptional Situations in the Compiler" - ;; requires this to be a STYLE-WARNING. + ;; requires this to be no more than a STYLE-WARNING. (compiler-style-warning "The variable ~S is defined but never used." - (leaf-name var))) - (setf (leaf-ever-used var) t)))) + (leaf-debug-name var))) + (setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN (values)) (defvar *deletion-ignored-objects* '(t nil)) @@ -1050,13 +1058,13 @@ ;;; triggered by deletion. (defun delete-component (component) (declare (type component component)) - (aver (null (component-new-functions component))) + (aver (null (component-new-funs component))) (setf (component-kind component) :deleted) (do-blocks (block component) (setf (block-delete-p block) t)) (dolist (fun (component-lambdas component)) (setf (functional-kind fun) nil) - (setf (functional-entry-function fun) nil) + (setf (functional-entry-fun fun) nil) (setf (leaf-refs fun) nil) (delete-functional fun)) (do-blocks (block component) @@ -1111,7 +1119,7 @@ ;;;; leaf hackery -;;; Change the Leaf that a Ref refers to. +;;; Change the LEAF that a REF refers to. (defun change-ref-leaf (ref leaf) (declare (type ref ref) (type leaf leaf)) (unless (eq (ref-leaf ref) leaf) @@ -1144,19 +1152,21 @@ ;;; Return a LEAF which represents the specified constant object. If ;;; the object is not in *CONSTANTS*, then we create a new constant ;;; LEAF and enter it. -#!-sb-fluid (declaim (maybe-inline find-constant)) (defun find-constant (object) - (if (typep object '(or symbol number character instance)) - (or (gethash object *constants*) - (setf (gethash object *constants*) - (make-constant :value object - :name nil - :type (ctype-of object) - :where-from :defined))) - (make-constant :value object - :name nil - :type (ctype-of object) - :where-from :defined))) + (if (typep object + ;; FIXME: What is the significance of this test? ("things + ;; that are worth uniquifying"?) + '(or symbol number character instance)) + (or (gethash object *constants*) + (setf (gethash object *constants*) + (make-constant :value object + :%source-name '.anonymous. + :type (ctype-of object) + :where-from :defined))) + (make-constant :value object + :%source-name '.anonymous. + :type (ctype-of object) + :where-from :defined))) ;;; If there is a non-local exit noted in ENTRY's environment that ;;; exits to CONT in that entry, then return it, otherwise return NIL. @@ -1216,7 +1226,7 @@ (or (not (defined-fun-p leaf)) (not (eq (defined-fun-inlinep leaf) :notinline)) notinline-ok)) - (leaf-name leaf) + (leaf-source-name leaf) nil)) nil)))