From 6075b05401346ac20ec9a647fe192a2a959f3882 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 28 May 2008 16:23:12 +0000 Subject: [PATCH] 1.0.17.3: unify CONSTANT nodes for DEFCONSTANT and literal constants * Prevents at least some cases which used to introduce duplicate constants into code objects. * The above causes all CONSTANTS being :DEFINED and anonymous, which is generally speaking not a problem, but causes trouble for XREF, which wants to generate REFERENCES information for constants as well. ...so, we add a %SOURCE-NAME slot to REF, allowing us to have references to a shared constant under multiple names. * Test-case. --- src/compiler/ir1tran.lisp | 15 +++++---------- src/compiler/ir1util.lisp | 28 ++++++++++++++-------------- src/compiler/node.lisp | 9 +++++++-- src/compiler/xref.lisp | 22 +++++++++++----------- tests/compiler.impure.lisp | 13 +++++++++++++ version.lisp-expr | 2 +- 6 files changed, 51 insertions(+), 38 deletions(-) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 328eb2e..0caaac5 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -241,11 +241,7 @@ (type (type-specifier (info :variable :type name)))) `(macro . (the ,type ,expansion)))) (:constant - (let ((value (info :variable :constant-value name))) - (make-constant :value value - :%source-name name - :type (ctype-of value) - :where-from where-from))) + (find-constant (info :variable :constant-value name))) (t (make-global-var :kind kind :%source-name name @@ -527,8 +523,7 @@ ;; needs to be. (defun reference-constant (start next result value) (declare (type ctran start next) - (type (or lvar null) result) - (inline find-constant)) + (type (or lvar null) result)) (ir1-error-bailout (start next result value) (when (producing-fasl-file) (maybe-emit-make-load-forms value)) @@ -566,7 +561,7 @@ ;;; needed. If LEAF represents a defined function which has already ;;; been converted, and is not :NOTINLINE, then reference the ;;; functional instead. -(defun reference-leaf (start next result leaf) +(defun reference-leaf (start next result leaf &optional (name '.anonymous.)) (declare (type ctran start next) (type (or lvar null) result) (type leaf leaf)) (when (functional-p leaf) (assure-functional-live-p leaf)) @@ -590,7 +585,7 @@ '(nil :optional))) (maybe-reanalyze-functional leaf)) leaf)) - (ref (make-ref leaf))) + (ref (make-ref leaf name))) (push ref (leaf-refs leaf)) (setf (leaf-ever-used leaf) t) (link-node-to-previous-ctran ref start) @@ -632,7 +627,7 @@ ;; processing our own code, though. #+sb-xc-host (warn "reading an ignored variable: ~S" name))) - (reference-leaf start next result var)) + (reference-leaf start next result var name)) (cons (aver (eq (car var) 'macro)) ;; FIXME: [Free] type declarations. -- APD, 2002-01-26 diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 6add010..3596ec2 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1570,20 +1570,20 @@ ;;; the object is not in *CONSTANTS*, then we create a new constant ;;; LEAF and enter it. (defun find-constant (object) - (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))) + (flet ((make-it () + (make-constant :value object + :%source-name '.anonymous. + :type (ctype-of object) + :where-from :defined))) + (if (and (typep object + ;; FIXME: What is the significance of this test? ("things + ;; that are worth uniquifying"?) + '(or symbol number character instance)) + (boundp '*constants*)) + (or (gethash object *constants*) + (setf (gethash object *constants*) + (make-it))) + (make-it)))) ;;; Return true if VAR would have to be closed over if environment ;;; analysis ran now (i.e. if there are any uses that have a different diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index ac17c72..37af448 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -672,7 +672,6 @@ ;; the value of the constant (value nil :type t)) (defprinter (constant :identity t) - (%source-name :test %source-name) value) ;;; The BASIC-VAR structure represents information common to all @@ -1142,14 +1141,20 @@ (def!struct (ref (:include valued-node (reoptimize nil)) (:constructor make-ref (leaf + &optional (%source-name '.anonymous.) &aux (leaf-type (leaf-type leaf)) (derived-type (make-single-value-type leaf-type)))) (:copier nil)) ;; The leaf referenced. - (leaf nil :type leaf)) + (leaf nil :type leaf) + ;; CONSTANT nodes are always anonymous, since we wish to coalesce named and + ;; unnamed constants that are equivalent, we need to keep track of the + ;; reference name for XREF. + (%source-name (missing-arg) :type symbol :read-only t)) (defprinter (ref :identity t) #!+sb-show id + %source-name leaf) ;;; Naturally, the IF node always appears at the end of a block. diff --git a/src/compiler/xref.lisp b/src/compiler/xref.lisp index 53dbaaf..ac1dad8 100644 --- a/src/compiler/xref.lisp +++ b/src/compiler/xref.lisp @@ -117,8 +117,7 @@ (record-xref :calls name context node nil))))) ;; Reading a constant (constant - (let* ((name (constant-%source-name leaf))) - (record-xref :references name context node nil)))))) + (record-xref :references (ref-%source-name node) context node nil))))) ;; Setting a special variable (cset (let* ((var (set-var node))) @@ -149,15 +148,16 @@ (list (every #'internal-name-p what)) (symbol - (member (symbol-package what) - (load-time-value (list* (find-package "COMMON-LISP") - (find-package "KEYWORD") - (remove-if-not - (lambda (package) - (= (mismatch "SB!" - (package-name package)) - 3)) - (list-all-packages)))))) + (or (eq '.anonymous. what) + (member (symbol-package what) + (load-time-value (list* (find-package "COMMON-LISP") + (find-package "KEYWORD") + (remove-if-not + (lambda (package) + (= (mismatch "SB!" + (package-name package)) + 3)) + (list-all-packages))))))) (t t))) (defun record-xref (kind what context node path) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index cb6ec00..8e78f57 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1551,4 +1551,17 @@ (not (or c d e f g h i j k l m n o p q r s)))))) (wants-many-values 1 42) +;;; constant coalescing (named and unnamed) +(defconstant +born-to-coalesce+ '.born-to-coalesce.) +(let* ((f (compile nil '(lambda () + (let ((x (cons +born-to-coalesce+ nil)) + (y (cons '.born-to-coalesce. nil))) + (list x y))))) + (b-t-c 0) + (code (sb-kernel:fun-code-header f))) + (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code) + do (when (eq '.born-to-coalesce. (sb-kernel:code-header-ref code i)) + (incf b-t-c))) + (assert (= 1 b-t-c))) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index f71279f..4f98205 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.17.2" +"1.0.17.3" -- 1.7.10.4