changes in sbcl-1.0.18 relative to 1.0.17:
* minor incompatible change: SB-SPROF:WITH-PROFILING now by default
profiles only the current thread.
+ * minor incompatible change: changes to SYMBOL-VALUE of constants
+ defined with DEFCONSTANT now signal an error.
* enhancement: SB-SPROF now has support for wallclock profiling,
and is also able to profile specific threads. REPORT output
has also additional sorting options.
as well.)
* optimization: simple uses of HANDLER-CASE and HANDLER-BIND no
longer cons.
+ * optimization: file compiler is now able to coalesce non-circular
+ lists, non-base strings, and bit-vectors. Additionally, constants
+ are never referenced through SYMBOL-VALUE at runtime.
* bug fix: EAI_NODATA is deprecated since RFC 3493. Stop using it
in sb-bsd-sockets.
* fixed some bugs revealed by Paul Dietz' test suite:
floating point backend with a compile-time option to switch between the
two.
--------------------------------------------------------------------------------
-#34
-Compiling
-
-(defun foo (x y)
- (declare (type (integer 0 45) x y))
- (+ x y))
-
-results in the following error trapping code for type-checking the
-arguments:
-
-; 424: L0: 8B058CE31812 MOV EAX, [#x1218E38C] ; '(MOD 46)
-; 42A: 0F0B0A BREAK 10 ; error trap
-; 42D: 05 BYTE #X05
-; 42E: 1F BYTE #X1F ; OBJECT-NOT-TYPE-ERROR
-; 42F: FECE01 BYTE #XFE, #XCE, #X01 ; EDI
-; 432: 0E BYTE #X0E ; EAX
-; 433: L1: 8B0590E31812 MOV EAX, [#x1218E390] ; '(MOD 46)
-; 439: 0F0B0A BREAK 10 ; error trap
-; 43C: 03 BYTE #X03
-; 43D: 1F BYTE #X1F ; OBJECT-NOT-TYPE-ERROR
-; 43E: 8E BYTE #X8E ; EDX
-; 43F: 0E BYTE #X0E ; EAX
-
-Notice that '(MOD 46) has two entries in the constant vector. Having
-one would be preferable.
---------------------------------------------------------------------------------
#35
Compiling
;; for everything.
("src/code/early-source-location")
+ ("src/code/early-constants")
+
;; This comes early because the cross-compilation host's backquote
;; logic can expand into something which can't be executed on the
;; target Lisp (e.g. in CMU CL where it expands into internal
"FLUSH-STANDARD-OUTPUT-STREAMS"
"WITH-UNIQUE-NAMES" "MAKE-GENSYM-LIST"
"ABOUT-TO-MODIFY-SYMBOL-VALUE"
- "SYMBOL-SELF-EVALUATING-P"
"SELF-EVALUATING-P"
"PRINT-PRETTY-ON-STREAM-P"
"ARRAY-READABLY-PRINTABLE-P"
(prog1 (eq 'lambda (caadr handler))
(setf lambda-form (cadr handler)))))
;; KLUDGE: DX-FLET doesn't handle non-required arguments yet.
- (not (intersection (second lambda-form) lambda-list-keywords)))
+ (not (intersection (second lambda-form) sb!xc:lambda-list-keywords)))
(let ((name (gensym "LAMBDA")))
(push `(,name ,@(cdr lambda-form)) local-funs)
(list type `(function ,name)))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(macrolet ((def (name value &optional doc)
+ (declare (ignorable doc))
+ `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
+ #!+sb-doc
+ ,@(when doc (list doc)))))
+ (def sb!xc:lambda-list-keywords
+ '(&allow-other-keys
+ &aux
+ &body
+ &environment
+ &key
+ &more
+ &optional
+ &rest
+ &whole)
+ "A list of symbols used as lambda list keywords in SBCL."))
((or (atom result)
(not (eq (car result) 'values)))
`(values ,result &optional))
- ((intersection (cdr result) lambda-list-keywords)
+ ((intersection (cdr result) sb!xc:lambda-list-keywords)
result)
(t `(values ,@(cdr result) &optional)))))
`(function ,args ,result)))
(char= #\* (aref name 0))
(char= #\* (aref name (1- (length name))))))))
-;;; Some symbols are defined by ANSI to be self-evaluating. Return
-;;; non-NIL for such symbols (and make the non-NIL value a traditional
-;;; message, for use in contexts where the user asks us to change such
-;;; a symbol).
-(defun symbol-self-evaluating-p (symbol)
- (declare (type symbol symbol))
- (cond ((eq symbol t)
- "Veritas aeterna. (can't change T)")
- ((eq symbol nil)
- "Nihil ex nihil. (can't change NIL)")
- ((keywordp symbol)
- "Keyword values can't be changed.")
- (t
- nil)))
-
-;;; This function is to be called just before a change which would
-;;; affect the symbol value. (We don't absolutely have to call this
-;;; function before such changes, since such changes are given as
-;;; undefined behavior. In particular, we don't if the runtime cost
-;;; would be annoying. But otherwise it's nice to do so.)
-(defun about-to-modify-symbol-value (symbol)
- (declare (type symbol symbol))
- (let ((reason (symbol-self-evaluating-p symbol)))
- (when reason
- (error reason)))
- ;; (Note: Just because a value is CONSTANTP is not a good enough
- ;; reason to complain here, because we want DEFCONSTANT to be able
- ;; to use this function, and it's legal to DEFCONSTANT a constant as
- ;; long as the new value is EQL to the old value.)
+;;; This function is to be called just before a change which would affect the
+;;; symbol value. We don't absolutely have to call this function before such
+;;; changes, since such changes to constants are given as undefined behavior,
+;;; it's nice to do so. To circumvent this you need code like this:
+;;;
+;;; (defvar foo)
+;;; (defun set-foo (x) (setq foo x))
+;;; (defconstant foo 42)
+;;; (set-foo 13)
+;;; foo => 13, (constantp 'foo) => t
+;;;
+;;; ...in which case you frankly deserve to lose.
+(defun about-to-modify-symbol-value (symbol action)
+ (declare (symbol symbol))
+ (multiple-value-bind (what continue)
+ (when (eq :constant (info :variable :kind symbol))
+ (cond ((eq symbol t)
+ (values "Veritas aeterna. (can't ~@?)" nil))
+ ((eq symbol nil)
+ (values "Nihil ex nihil. (can't ~@?)" nil))
+ ((keywordp symbol)
+ (values "Can't ~@?." nil))
+ (t
+ (values "Constant modification: attempt to ~@?." t))))
+ (when what
+ (if continue
+ (cerror "Modify the constant." what action symbol)
+ (error what action symbol))))
(values))
-
;;; If COLD-FSET occurs not at top level, just treat it as an ordinary
;;; assignment instead of doing cold static linking. That way things like
;;; (FLET ((FROB (X) ..))
(lambda (f)
(let ((args (cadr f))
(name (car f)))
- (when (intersection args lambda-list-keywords)
+ (when (intersection args sb!xc:lambda-list-keywords)
;; No fundamental reason not to support them, but we
;; don't currently need them here.
(error "Non-required arguments not implemented for DX-FLET."))
(typecase exp
(symbol
(ecase (info :variable :kind exp)
- (:constant
- (values (info :variable :constant-value exp)))
- ((:special :global)
+ ((:special :global :constant)
(symbol-value exp))
;; FIXME: This special case here is a symptom of non-ANSI
;; weirdness in SBCL's ALIEN implementation, which could
(error "Invalid first argument to COMPARE-AND-SWAP: ~S" place))))))))
(macrolet ((def (name lambda-list ref &optional set)
+ #!+compare-and-swap-vops
+ (declare (ignore ref set))
`(defun ,name (,@lambda-list old new)
#!+compare-and-swap-vops
- (declare (ignore ref set))
- #!+compare-and-swap-vops
(,name ,@lambda-list old new)
#!-compare-and-swap-vops
(let ((current (,ref ,@lambda-list)))
#!+sb-doc
"Set SYMBOL's value cell to NEW-VALUE."
(declare (type symbol symbol))
- (about-to-modify-symbol-value symbol)
+ (about-to-modify-symbol-value symbol "set SYMBOL-VALUE of ~S")
(%set-symbol-value symbol new-value))
(defun %set-symbol-value (symbol new-value)
(%set-symbol-value symbol new-value))
+(declaim (inline %makunbound))
+(defun %makunbound (symbol)
+ (%set-symbol-value symbol (%primitive sb!c:make-other-immediate-type
+ 0 sb!vm:unbound-marker-widetag)))
+
(defun makunbound (symbol)
#!+sb-doc
"Make SYMBOL unbound, removing any value it may currently have."
(with-single-package-locked-error (:symbol symbol "unbinding the symbol ~A")
- (set symbol
- (%primitive sb!c:make-other-immediate-type
- 0
- sb!vm:unbound-marker-widetag))
+ (about-to-modify-symbol-value symbol "make ~S unbound")
+ (%makunbound symbol)
symbol))
;;; Return the built-in hash value for SYMBOL.
(defun %define-alien-variable (lisp-name alien-name type)
(setf (info :variable :kind lisp-name) :alien)
(setf (info :variable :where-from lisp-name) :defined)
- (clear-info :variable :constant-value lisp-name)
(setf (info :variable :alien-info lisp-name)
(make-heap-alien-info :type type
:sap-form `(foreign-symbol-sap ',alien-name t)))))
(setq *keyword-package* (find-package "KEYWORD"))
(/show0 "about to MAKUNBOUND *!INITIAL-SYMBOLS*")
- (makunbound '*!initial-symbols*) ; (so that it gets GCed)
+ (%makunbound '*!initial-symbols*) ; (so that it gets GCed)
;; Make some other packages that should be around in the cold load.
;; The COMMON-LISP-USER package is required by the ANSI standard,
;; instead of general (not handling cases like &key (x y))
(declare (ignorable
,@(remove-if (lambda (arg)
- (member arg lambda-list-keywords))
+ (member arg sb!xc:lambda-list-keywords))
lambda-list)))
,body))))
`(progn
(defun sb!c::%defconstant (name value doc source-location)
(unless (symbolp name)
(error "The constant name is not a symbol: ~S" name))
- (about-to-modify-symbol-value name)
(when (looks-like-name-of-special-var-p name)
(style-warn "defining ~S as a constant, even though the name follows~@
the usual naming convention (names like *FOO*) for special variables"
;; appropriate, despite the un-mnemonic name), or defining
;; something like the DEFCONSTANT-EQX macro used in SBCL (which
;; is occasionally more appropriate). -- WHN 2001-12-21
- (unless (eql value
- (info :variable :constant-value name))
- (multiple-value-bind (ignore aborted)
- (with-simple-restart (abort "Keep the old value.")
- (cerror "Go ahead and change the value."
- 'defconstant-uneql
- :name name
- :old-value (info :variable :constant-value name)
- :new-value value))
- (declare (ignore ignore))
- (when aborted
- (return-from sb!c::%defconstant name)))))
+ (if (boundp name)
+ (if (typep name '(or boolean keyword))
+ ;; Non-continuable error.
+ (about-to-modify-symbol-value name "define ~S as a constant")
+ (let ((old (symbol-value name)))
+ (unless (eql value old)
+ (multiple-value-bind (ignore aborted)
+ (with-simple-restart (abort "Keep the old value.")
+ (cerror "Go ahead and change the value."
+ 'defconstant-uneql
+ :name name
+ :old-value old
+ :new-value value))
+ (declare (ignore ignore))
+ (when aborted
+ (return-from sb!c::%defconstant name))))))
+ (warn "redefining a MAKUNBOUND constant: ~S" name)))
(:global
;; (This is OK -- undefined variables are of this kind. So we
;; don't warn or error or anything, just fall through.)
(when doc
(setf (fdocumentation name 'variable) doc))
#-sb-xc-host
- (setf (symbol-value name) value)
+ (%set-symbol-value name value)
#+sb-xc-host
(progn
- ;; Redefining our cross-compilation host's CL symbols
- ;; would be poor form.
- ;;
- ;; FIXME: Having to check this and then not treat it
- ;; as a fatal error seems like a symptom of things
- ;; being pretty broken. It's also a problem in and of
- ;; itself, since it makes it too easy for cases of
- ;; using the cross-compilation host Lisp's CL
- ;; constant values in the target Lisp to slip by. I
- ;; got backed into this because the cross-compiler
- ;; translates DEFCONSTANT SB!XC:FOO into DEFCONSTANT
- ;; CL:FOO. It would be good to unscrew the
- ;; cross-compilation package hacks so that that
- ;; translation doesn't happen. Perhaps:
- ;; * Replace SB-XC with SB-CL. SB-CL exports all the
- ;; symbols which ANSI requires to be exported from CL.
- ;; * Make a nickname SB!CL which behaves like SB!XC.
- ;; * Go through the loaded-on-the-host code making
- ;; every target definition be in SB-CL. E.g.
- ;; DEFMACRO-MUNDANELY DEFCONSTANT becomes
- ;; DEFMACRO-MUNDANELY SB!CL:DEFCONSTANT.
- ;; * Make IN-TARGET-COMPILATION-MODE do
- ;; UNUSE-PACKAGE CL and USE-PACKAGE SB-CL in each
- ;; of the target packages (then undo it on exit).
- ;; * Make the cross-compiler's implementation of
- ;; EVAL-WHEN (:COMPILE-TOPLEVEL) do UNCROSS.
- ;; (This may not require any change.)
- ;; * Hack GENESIS as necessary so that it outputs
- ;; SB-CL stuff as COMMON-LISP stuff.
- ;; * Now the code here can assert that the symbol
- ;; being defined isn't in the cross-compilation
- ;; host's CL package.
- (unless (eql (find-symbol (symbol-name name) :cl) name)
- ;; KLUDGE: In the cross-compiler, we use the
- ;; cross-compilation host's DEFCONSTANT macro
- ;; instead of just (SETF SYMBOL-VALUE), in order to
- ;; get whatever blessing the cross-compilation host
- ;; may expect for a global (SETF SYMBOL-VALUE).
- ;; (CMU CL, at least around 2.4.19, generated full
- ;; WARNINGs for code -- e.g. DEFTYPE expanders --
- ;; which referred to symbols which had been set by
- ;; (SETF SYMBOL-VALUE). I doubt such warnings are
- ;; ANSI-compliant, but I'm not sure, so I've
- ;; written this in a way that CMU CL will tolerate
- ;; and which ought to work elsewhere too.) -- WHN
- ;; 2001-03-24
- (eval `(defconstant ,name ',value))))
-
- (setf (info :variable :kind name) :constant
- (info :variable :constant-value name) value)
+ ;; Redefining our cross-compilation host's CL symbols would be poor form.
+ ;;
+ ;; FIXME: Having to check this and then not treat it as a fatal error
+ ;; seems like a symptom of things being pretty broken. It's also a problem
+ ;; in and of itself, since it makes it too easy for cases of using the
+ ;; cross-compilation host Lisp's CL constant values in the target Lisp to
+ ;; slip by. I got backed into this because the cross-compiler translates
+ ;; DEFCONSTANT SB!XC:FOO into DEFCONSTANT CL:FOO. It would be good to
+ ;; unscrew the cross-compilation package hacks so that that translation
+ ;; doesn't happen. Perhaps: * Replace SB-XC with SB-CL. SB-CL exports all
+ ;; the symbols which ANSI requires to be exported from CL. * Make a
+ ;; nickname SB!CL which behaves like SB!XC. * Go through the
+ ;; loaded-on-the-host code making every target definition be in SB-CL.
+ ;; E.g. DEFMACRO-MUNDANELY DEFCONSTANT becomes DEFMACRO-MUNDANELY
+ ;; SB!CL:DEFCONSTANT. * Make IN-TARGET-COMPILATION-MODE do UNUSE-PACKAGE
+ ;; CL and USE-PACKAGE SB-CL in each of the target packages (then undo it
+ ;; on exit). * Make the cross-compiler's implementation of EVAL-WHEN
+ ;; (:COMPILE-TOPLEVEL) do UNCROSS. (This may not require any change.) *
+ ;; Hack GENESIS as necessary so that it outputs SB-CL stuff as COMMON-LISP
+ ;; stuff. * Now the code here can assert that the symbol being defined
+ ;; isn't in the cross-compilation host's CL package.
+ (unless (eql (find-symbol (symbol-name name) :cl) name)
+ ;; KLUDGE: In the cross-compiler, we use the cross-compilation host's
+ ;; DEFCONSTANT macro instead of just (SETF SYMBOL-VALUE), in order to
+ ;; get whatever blessing the cross-compilation host may expect for a
+ ;; global (SETF SYMBOL-VALUE). (CMU CL, at least around 2.4.19,
+ ;; generated full WARNINGs for code -- e.g. DEFTYPE expanders -- which
+ ;; referred to symbols which had been set by (SETF SYMBOL-VALUE). I
+ ;; doubt such warnings are ANSI-compliant, but I'm not sure, so I've
+ ;; written this in a way that CMU CL will tolerate and which ought to
+ ;; work elsewhere too.) -- WHN 2001-03-24
+ (eval `(defconstant ,name ',value))))
+ (setf (info :variable :kind name) :constant)
name)
#!+sb-doc
"The exclusive upper bound on the number of multiple VALUES that you can
return.")
-
-(defconstant-eqx sb!xc:lambda-list-keywords
- '(&allow-other-keys
- &aux
- &body
- &environment
- &key
- &more
- &optional
- &rest
- &whole)
- #'equal
- #!+sb-doc
- "symbols which are magical in a lambda list")
\f
;;;; cross-compiler-only versions of CL special variables, so that we
;;;; don't have weird interactions with the host compiler
(let ((result (symbol-package symbol)))
(unless (package-ok-for-target-symbol-p result)
(bug "~A in bad package for target: ~A" symbol result))
- (aver (package-ok-for-target-symbol-p result))
result))))
;;; Return a handle on an interned symbol. If necessary allocate the
(check-type kind (member :untagged :tagged))
(check-type width unsigned-byte)
(dolist (arg lambda-list)
- (when (member arg lambda-list-keywords)
+ (when (member arg sb!xc:lambda-list-keywords)
(error "Lambda list keyword ~S is not supported for ~
modular function lambda lists." arg)))
`(progn
(check-type name symbol)
(check-type kind (member :untagged :tagged))
(dolist (arg lambda-list)
- (when (member arg lambda-list-keywords)
+ (when (member arg sb!xc:lambda-list-keywords)
(error "Lambda list keyword ~S is not supported for ~
modular function lambda lists." arg)))
(with-unique-names (call args)
:class :variable
:type :kind
:type-spec (member :special :constant :macro :global :alien)
- :default (if (symbol-self-evaluating-p name)
+ :default (if (typep name '(or boolean keyword))
:constant
:global))
:type-spec (member :declared :assumed :defined)
:default :assumed)
-;;; the Lisp object which is the value of this constant, if known
-(define-info-type
- :class :variable
- :type :constant-value
- :type-spec t
- ;; CMU CL used to return two values for (INFO :VARIABLE :CONSTANT-VALUE ..).
- ;; Now we don't: it was the last remaining multiple-value return from
- ;; the INFO system, and bringing it down to one value lets us simplify
- ;; things, especially simplifying the declaration of return types.
- ;; Software which used to check the second value (for "is it defined
- ;; as a constant?") should check (EQL (INFO :VARIABLE :KIND ..) :CONSTANT)
- ;; instead.
- :default (if (symbol-self-evaluating-p name)
- name
- (bug "constant lookup of nonconstant ~S" name)))
-
;;; the macro-expansion for symbol-macros
(define-info-type
:class :variable
(compiler-error "odd number of args to SETQ: ~S" source))
(if (= len 2)
(let* ((name (first things))
- (leaf (or (lexenv-find name vars)
- (find-free-var name))))
+ (value-form (second things))
+ (leaf (or (lexenv-find name vars) (find-free-var name))))
(etypecase leaf
(leaf
(when (constant-p leaf)
(compiler-style-warn
"~S is being set even though it was declared to be ignored."
name)))
- (setq-var start next result leaf (second things)))
+ (if (and (global-var-p leaf) (eq :global (global-var-kind leaf)))
+ ;; For undefined variables go through SET, so that we can catch
+ ;; constant modifications.
+ (ir1-convert start next result `(set ',name ,value-form))
+ (setq-var start next result leaf value-form)))
(cons
(aver (eq (car leaf) 'macro))
;; FIXME: [Free] type declaration. -- APD, 2002-01-26
(type (type-specifier (info :variable :type name))))
`(macro . (the ,type ,expansion))))
(:constant
- (find-constant (info :variable :constant-value name)))
+ (find-constant (symbol-value name) name))
(t
(make-global-var :kind kind
:%source-name name
;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD)
;; below. -- AL 20010227
(def!constant list-to-hash-table-threshold 32))
-(defun maybe-emit-make-load-forms (constant)
+(defun maybe-emit-make-load-forms (constant &optional (name nil namep))
(let ((things-processed nil)
(count 0))
;; FIXME: Does this LIST-or-HASH-TABLE messiness give much benefit?
;; can't contain other objects
(unless (typep value
'(or #-sb-xc-host unboxed-array
- #+sb-xc-host (simple-array (unsigned-byte 8) (*))
- symbol
- number
- character
- string))
+ #+sb-xc-host (simple-array (unsigned-byte 8) (*))
+ symbol
+ number
+ character
+ string))
(etypecase things-processed
(list
(when (member value things-processed :test #'eq)
;; instances, only on STRUCTURE!OBJECTs.
#+sb-xc-host structure!object
#-sb-xc-host instance
- (when (emit-make-load-form value)
+ (when (if namep
+ (emit-make-load-form value name)
+ (emit-make-load-form value))
(dotimes (i (- (%instance-length value)
#+sb-xc-host 0
#-sb-xc-host (layout-n-untagged-slots
;;; LEAF and enter it. If we are producing a fasl file, make sure that
;;; MAKE-LOAD-FORM gets used on any parts of the constant that it
;;; needs to be.
-(defun find-constant (object)
- (flet ((make-it ()
- (when (producing-fasl-file)
- (maybe-emit-make-load-forms object))
- (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))))
+;;;
+;;; We are allowed to coalesce things like EQUAL strings and bit-vectors
+;;; when file-compiling, but not when using COMPILE.
+(defun find-constant (object &optional (name nil namep))
+ (let ((faslp (producing-fasl-file)))
+ (labels ((make-it ()
+ (when faslp
+ (if namep
+ (maybe-emit-make-load-forms object name)
+ (maybe-emit-make-load-forms object)))
+ (make-constant object))
+ (core-coalesce-p (x)
+ ;; True for things which retain their identity under EQUAL,
+ ;; so we can safely share the same CONSTANT leaf between
+ ;; multiple references.
+ (or (typep x '(or symbol number character))
+ ;; Amusingly enough, we see CLAMBDAs --among other things--
+ ;; here, from compiling things like %ALLOCATE-CLOSUREs forms.
+ ;; No point in stuffing them in the hash-table.
+ (and (typep x 'instance)
+ (not (or (leaf-p x) (node-p x))))))
+ (file-coalesce-p (x)
+ ;; CLHS 3.2.4.2.2: We are also allowed to coalesce various
+ ;; other things when file-compiling.
+ (or (core-coalesce-p x)
+ (if (consp x)
+ (if (eq +code-coverage-unmarked+ (cdr x))
+ ;; These are already coalesced, and the CAR should
+ ;; always be OK, so no need to check.
+ t
+ (unless (maybe-cyclic-p x) ; safe for EQUAL?
+ (do ((y x (cdr y)))
+ ((atom y) (file-coalesce-p y))
+ (unless (file-coalesce-p (car y))
+ (return nil)))))
+ ;; We *could* coalesce base-strings as well, but we'd need
+ ;; a separate hash-table for that, since we are not allowed to
+ ;; coalesce base-strings with non-base-strings.
+ (typep x '(or (vector character) bit-vector)))))
+ (coalescep (x)
+ (if faslp (file-coalesce-p x) (core-coalesce-p x))))
+ (if (and (boundp '*constants*) (coalescep object))
+ (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
(vop value-cell-ref node block tn res)
(emit-move node block tn res))))
(constant
- (if (legal-immediate-constant-p leaf)
- (emit-move node block (constant-tn leaf) res)
- (let* ((name (leaf-source-name leaf))
- (name-tn (emit-constant name)))
- (if (policy node (zerop safety))
- (vop fast-symbol-value node block name-tn res)
- (vop symbol-value node block name-tn res)))))
+ (emit-move node block (constant-tn leaf) res))
(functional
(ir2-convert-closure node block leaf res))
(global-var
(emit-move node block val tn)))))
(global-var
(ecase (global-var-kind leaf)
- ((:special :global)
+ ((:special)
(aver (symbolp (leaf-source-name leaf)))
(vop set node block (emit-constant (leaf-source-name leaf)) val)))))
(when locs
(declare (type lvar lvar))
(ir2-lvar-primitive-type (lvar-info lvar)))
-;;; Return true if a constant LEAF is of a type which we can legally
-;;; directly reference in code. Named constants with arbitrary pointer
-;;; values cannot, since we must preserve EQLness.
-;;;
-;;; FIXME: why not? The values in a function's constant vector are
-;;; subject to being moved by the garbage collector. Having arbitrary
-;;; values in said vector doesn't seem like a problem.
-(defun legal-immediate-constant-p (leaf)
- (declare (type constant leaf))
- (or (not (leaf-has-source-name-p leaf))
- ;; Specialized arrays are legal, too. KLUDGE: this would be
- ;; *much* cleaner if SIMPLE-UNBOXED-ARRAY was defined on the host.
- #.(loop for saetp across sb!vm:*specialized-array-element-type-properties*
- unless (eq t (sb!vm:saetp-specifier saetp))
- collect `((simple-array ,(sb!vm:saetp-specifier saetp) (*)) t) into cases
- finally (return
- `(typecase (constant-value leaf)
- ((or number character) t)
- (symbol (symbol-package (constant-value leaf)))
- ,@cases
- (t nil))))))
-
;;; If LVAR is used only by a REF to a leaf that can be delayed, then
;;; return the leaf, otherwise return NIL.
(defun lvar-delayed-leaf (lvar)
(let ((leaf (ref-leaf use)))
(etypecase leaf
(lambda-var (if (null (lambda-var-sets leaf)) leaf nil))
- (constant (if (legal-immediate-constant-p leaf) leaf nil))
+ (constant leaf)
((or functional global-var) nil))))))
;;; Annotate a normal single-value lvar. If its only use is a ref that
(defvar *constants-being-created* nil)
(defvar *constants-created-since-last-init* nil)
;;; FIXME: Shouldn't these^ variables be unbound outside LET forms?
-(defun emit-make-load-form (constant)
+(defun emit-make-load-form (constant &optional (name nil namep))
(aver (fasl-output-p *compile-object*))
(unless (or (fasl-constant-already-dumped-p constant *compile-object*)
;; KLUDGE: This special hack is because I was too lazy
(throw constant t))
(throw 'pending-init circular-ref)))
(multiple-value-bind (creation-form init-form)
- (handler-case
- (sb!xc:make-load-form constant (make-null-lexenv))
- (error (condition)
- (compiler-error condition)))
+ (if namep
+ ;; If the constant is a reference to a named constant, we can
+ ;; just use SYMBOL-VALUE during LOAD.
+ (values `(symbol-value ',name) nil)
+ (handler-case
+ (sb!xc:make-load-form constant (make-null-lexenv))
+ (error (condition)
+ (compiler-error condition))))
(case creation-form
(:sb-just-dump-it-normally
(fasl-validate-structure constant *compile-object*)
(functional-%debug-name leaf)))
;;; The CONSTANT structure is used to represent known constant values.
-;;; If NAME is not null, then it is the name of the named constant
-;;; which this leaf corresponds to, otherwise this is an anonymous
-;;; constant.
-(def!struct (constant (:include leaf))
+;;; Since the same constant leaf may be shared between named and anonymous
+;;; constants, %SOURCE-NAME is never used.
+(def!struct (constant (:constructor make-constant (value
+ &aux
+ (type (ctype-of value))
+ (%source-name '.anonynous.)
+ (where-from :defined)))
+ (:include leaf))
;; the value of the constant
- (value nil :type t))
+ (value (missing-arg) :type t))
(defprinter (constant :identity t)
value)
(dolist (name args)
(unless (symbolp name)
(error "can't declare a non-symbol as SPECIAL: ~S" name))
- (when (sb!xc:constantp name)
- (error "can't declare a constant as SPECIAL: ~S" name))
(with-single-package-locked-error
- (:symbol name "globally declaring ~A special"))
- (clear-info :variable :constant-value name)
- (setf (info :variable :kind name) :special)))
+ (:symbol name "globally declaring ~A special")
+ (about-to-modify-symbol-value name "proclaim ~S as SPECIAL")
+ (setf (info :variable :kind name) :special))))
(type
(if *type-system-initialized*
(let ((type (specifier-type (first args))))
&aux arg)
(cond ((null arglist) ())
((symbolp (setq arg (car arglist)))
- (or (member arg lambda-list-keywords :test #'eq)
+ (or (member arg sb!xc:lambda-list-keywords :test #'eq)
(note-lexical-binding arg env))
(recons arglist
arg
context
env
(and destructuringp
- (not (member arg
- lambda-list-keywords))))))
+ (not (member arg sb!xc:lambda-list-keywords))))))
((consp arg)
(prog1 (recons arglist
(if destructuringp
(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)
+;;; constant coalescing
+
+(defun count-code-constants (x f)
+ (let ((code (sb-kernel:fun-code-header f))
+ (n 0))
+ (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code)
+ do (when (equal x (sb-kernel:code-header-ref code i))
+ (incf n)))
+ n))
+
+(defvar *lambda*)
+
+(defun compile2 (lambda)
+ (let* ((lisp "compiler-impure-tmp.lisp")
+ (fasl (compile-file-pathname lisp)))
+ (unwind-protect
+ (progn
+ (with-open-file (f lisp :direction :output)
+ (prin1 `(setf *lambda* ,lambda) f))
+ (multiple-value-bind (fasl warn fail) (compile-file lisp)
+ (declare (ignore warn))
+ (when fail
+ (error "File-compiling ~S failed." lambda))
+ (let ((*lambda* nil))
+ (load fasl)
+ (values *lambda* (compile nil lambda)))))
+ (ignore-errors (delete-file lisp))
+ (ignore-errors (delete-file fasl)))))
+
+;; 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)))
+(multiple-value-bind (file-fun core-fun)
+ (compile2 '(lambda ()
+ (let ((x (cons +born-to-coalesce+ nil))
+ (y (cons '.born-to-coalesce. nil)))
+ (list x y))))
+ (assert (= 1 (count-code-constants '.born-to-coalesce. file-fun)))
+ (assert (= 1 (count-code-constants '.born-to-coalesce. core-fun))))
+
+;; some things must retain identity under COMPILE, but we want to coalesce them under COMPILE-FILE
+(defun assert-coalescing (constant)
+ (let ((value (copy-seq (symbol-value constant))))
+ (multiple-value-bind (file-fun core-fun)
+ (compile2 `(lambda ()
+ (let ((x (cons ,constant nil))
+ (y (cons ',value nil)))
+ (list x y))))
+ (assert (= 1 (count-code-constants value file-fun)))
+ (assert (= 2 (count-code-constants value core-fun)))
+ (let* ((l (funcall file-fun))
+ (a (car (first l)))
+ (b (car (second l))))
+ (assert (and (equal value a)
+ (equal a b)
+ (eq a b))))
+ (let* ((l (funcall core-fun))
+ (a (car (first l)))
+ (b (car (second l))))
+ (assert (and (equal value a)
+ (equal a b)
+ (not (eq a b))))))))
+
+(defconstant +born-to-coalesce2+ "maybe coalesce me!")
+(assert-coalescing '+born-to-coalesce2+)
+
+(defconstant +born-to-coalesce3+ #*01101001011101110100011)
+(assert-coalescing '+born-to-coalesce3+)
+
+(defconstant +born-to-coalesce4+ '(foo bar "zot" 123 (nested "quux") #*0101110010))
+(assert-coalescing '+born-to-coalesce4+)
+
+;;; catch constant modifications thru undefined variables
+(defun sneak-set-dont-set-me (x)
+ (ignore-errors (setq dont-set-me x)))
+(defconstant dont-set-me 42)
+(assert (not (sneak-set-dont-set-me 13)))
+(assert (= 42 dont-set-me))
+(defclass some-constant-thing () ())
+(defun sneak-set-dont-set-me2 (x)
+ (ignore-errors (setq dont-set-me2 x)))
+(defconstant dont-set-me2 (make-instance 'some-constant-thing))
+(assert (not (sneak-set-dont-set-me2 13)))
+(assert (typep dont-set-me2 'some-constant-thing))
;;; success
:constant))
;;; It's possible in general for a constant to have the value NIL, but
;;; not for vector-data-offset, which must be a number:
-(multiple-value-bind (value successp)
- (sb!int:info :variable :constant-value 'sb!vm:vector-data-offset)
- (assert value)
- (assert successp))
+(assert (boundp 'sb!vm:vector-data-offset))
+(assert (integerp (symbol-value 'sb!vm:vector-data-offset)))
(/show "done with tests/info.before-xc.lisp")
;;; 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.23"
+"1.0.17.24"
projects / sbcl.git / commitdiff