From 45bc305be4e269d2e1a477c8e0ae9a64df1ccd1c Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 4 Jun 2008 12:39:38 +0000 Subject: [PATCH] 1.0.17.24: refactor handling of constants in the compiler * Coalesce non-circular lists, bit-vectors, and non-base-strings in the file-compiler. (We could do more, but these are the "easy" ones.) Takes care of OPTIMIZATIONS #34 in practice: outside the file compiler one can still trick the system into similar behaviour, but that seems a fairly academic concern. * Never go through SYMBOL-VALUE at runtime to fetch the value of a constant variable in compiled code. * Use (SYMBOL-VALUE ) as the load-form to dump references to named constants into fasls. * Signal a continuable error if an attempt to change the SYMBOL-VALUE of a constant variable is made. * Assignments to undefined variables go through SET, so that one cannot accidentally modify a constant by doing something like: (defun set-foo (x) (setq foo x)) (defconstant foo 42) (set-foo 13) * Gets rid of INFO :VARIABLE :CONSTANT-VALUE, and just uses SYMBOL-VALUE to store constant values. * Move definition of SB!XC:LAMBDA-LIST-KEYWORDS to be beginning of the build, and use it instead of the host LAMBDA-LIST-KEYWORDS where appropriate. * Tests. --- NEWS | 5 ++ OPTIMIZATIONS | 26 --------- build-order.lisp-expr | 2 + package-data-list.lisp-expr | 1 - src/code/defboot.lisp | 2 +- src/code/early-constants.lisp | 27 +++++++++ src/code/early-extensions.lisp | 62 ++++++++++---------- src/code/eval.lisp | 4 +- src/code/late-extensions.lisp | 4 +- src/code/symbol.lisp | 13 +++-- src/code/target-alieneval.lisp | 1 - src/code/target-package.lisp | 2 +- src/compiler/constantp.lisp | 2 +- src/compiler/defconstant.lisp | 115 ++++++++++++++++--------------------- src/compiler/early-c.lisp | 14 ----- src/compiler/generic/genesis.lisp | 1 - src/compiler/generic/vm-macs.lisp | 4 +- src/compiler/globaldb.lisp | 18 +----- src/compiler/ir1-translators.lisp | 10 +++- src/compiler/ir1tran.lisp | 18 +++--- src/compiler/ir1util.lisp | 63 ++++++++++++++------ src/compiler/ir2tran.lisp | 10 +--- src/compiler/ltn.lisp | 24 +------- src/compiler/main.lisp | 14 +++-- src/compiler/node.lisp | 14 +++-- src/compiler/proclaim.lisp | 8 +-- src/pcl/walk.lisp | 5 +- tests/compiler.impure.lisp | 93 ++++++++++++++++++++++++++---- tests/info.before-xc.lisp | 6 +- version.lisp-expr | 2 +- 30 files changed, 306 insertions(+), 264 deletions(-) create mode 100644 src/code/early-constants.lisp diff --git a/NEWS b/NEWS index 348f800..ecd853e 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,8 @@ 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. @@ -14,6 +16,9 @@ changes in sbcl-1.0.18 relative to 1.0.17: 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: diff --git a/OPTIMIZATIONS b/OPTIMIZATIONS index 0308f85..bc02982 100644 --- a/OPTIMIZATIONS +++ b/OPTIMIZATIONS @@ -311,32 +311,6 @@ using the x86 FP stack. It would be nice if SBCL included an SSE2-based 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 diff --git a/build-order.lisp-expr b/build-order.lisp-expr index e0f43e7..7e8962f 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -43,6 +43,8 @@ ;; 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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index c27b7b9..65fd2e2 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1068,7 +1068,6 @@ possibly temporariliy, because it might be used internally." "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" diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index b2189a4..38199fa 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -582,7 +582,7 @@ evaluated as a PROGN." (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))) diff --git a/src/code/early-constants.lisp b/src/code/early-constants.lisp new file mode 100644 index 0000000..0d394fd --- /dev/null +++ b/src/code/early-constants.lisp @@ -0,0 +1,27 @@ +;;;; 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.")) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index a77d82e..ac0552d 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -102,7 +102,7 @@ ((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))) @@ -755,38 +755,36 @@ (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) ..)) @@ -1240,7 +1238,7 @@ to :INTERPRET, an interpreter will be used.") (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.")) diff --git a/src/code/eval.lisp b/src/code/eval.lisp index 39c295d..53de408 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -125,9 +125,7 @@ (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 diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp index 08dbd57..e6b24a3 100644 --- a/src/code/late-extensions.lisp +++ b/src/code/late-extensions.lisp @@ -124,10 +124,10 @@ EXPERIMENTAL: Interface subject to change." (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))) diff --git a/src/code/symbol.lisp b/src/code/symbol.lisp index f4a7888..10fd742 100644 --- a/src/code/symbol.lisp +++ b/src/code/symbol.lisp @@ -32,20 +32,23 @@ #!+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. diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index d674b64..08e8b9e 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -66,7 +66,6 @@ (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))))) diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index d4876ef..24af5a1 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -1407,7 +1407,7 @@ PACKAGE." (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, diff --git a/src/compiler/constantp.lisp b/src/compiler/constantp.lisp index 0e2f4af..29252c2 100644 --- a/src/compiler/constantp.lisp +++ b/src/compiler/constantp.lisp @@ -145,7 +145,7 @@ constantness of the FORM in ENVIRONMENT." ;; 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 diff --git a/src/compiler/defconstant.lisp b/src/compiler/defconstant.lisp index 735f29a..5f155eb 100644 --- a/src/compiler/defconstant.lisp +++ b/src/compiler/defconstant.lisp @@ -23,7 +23,6 @@ (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" @@ -41,18 +40,23 @@ 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.) @@ -61,57 +65,40 @@ the usual naming convention (names like *FOO*) for special variables" (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) diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index a8e47b0..3be5dcf 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -29,20 +29,6 @@ #!+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") ;;;; cross-compiler-only versions of CL special variables, so that we ;;;; don't have weird interactions with the host compiler diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 2e68ef4..843cc73 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1110,7 +1110,6 @@ core and return a descriptor to it." (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 diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp index 096890f..482bd35 100644 --- a/src/compiler/generic/vm-macs.lisp +++ b/src/compiler/generic/vm-macs.lisp @@ -249,7 +249,7 @@ (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 @@ -278,7 +278,7 @@ (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) diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index bb75e15..8436730 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -1066,7 +1066,7 @@ :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)) @@ -1084,22 +1084,6 @@ :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 diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index a6a6f64..d26e53a 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -900,8 +900,8 @@ care." (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) @@ -916,7 +916,11 @@ care." (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 diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 6f08a8b..16ea19b 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -241,7 +241,7 @@ (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 @@ -256,7 +256,7 @@ ;; 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? @@ -268,11 +268,11 @@ ;; 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) @@ -315,7 +315,9 @@ ;; 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 diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 29fa7cd..f522cfc 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1571,23 +1571,52 @@ ;;; 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))))) ;;; 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/ir2tran.lisp b/src/compiler/ir2tran.lisp index f2c5381..e98d839 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -135,13 +135,7 @@ (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 @@ -306,7 +300,7 @@ (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 diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index b790f42..b707b76 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -64,28 +64,6 @@ (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) @@ -95,7 +73,7 @@ (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 diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 0c1ce53..9bdf959 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1812,7 +1812,7 @@ SPEED and COMPILATION-SPEED optimization values, and the (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 @@ -1828,10 +1828,14 @@ SPEED and COMPILATION-SPEED optimization values, and the (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*) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 37af448..afcb90d 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -665,12 +665,16 @@ (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) diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 57ad824..93de835 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -172,12 +172,10 @@ (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)))) diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index 1a7bf6f..ba16dfa 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -668,7 +668,7 @@ &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 @@ -676,8 +676,7 @@ 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 diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 8e78f57..89a9d83 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1551,17 +1551,88 @@ (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 diff --git a/tests/info.before-xc.lisp b/tests/info.before-xc.lisp index 9bdbfc2..34ed298 100644 --- a/tests/info.before-xc.lisp +++ b/tests/info.before-xc.lisp @@ -21,9 +21,7 @@ :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") diff --git a/version.lisp-expr b/version.lisp-expr index 5d8d32d..835b52b 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.23" +"1.0.17.24" -- 1.7.10.4