(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
;; 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))
;;; 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))
'(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)
;; 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
;;; 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))))
\f
;;; 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
;; 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
(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.
(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)))
(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)
(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
;;; 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"
projects / sbcl.git / commitdiff