common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

1.0.17.24: refactor handling of constants in the compiler

Browse source 
* 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 <NAME>) 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.
This commit is contained in:
Nikodemus Siivola 2008-06-04 12:39:38 +00:00
parent 8ee41eac13
commit 45bc305be4
30 changed files with 306 additions and 264 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
NEWS
View file

@ -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:

26
OPTIMIZATIONS
View file

@ -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

2
build-order.lisp-expr
View file

@ -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

1
package-data-list.lisp-expr
View file

@ -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"

2
src/code/defboot.lisp
View file

@ -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)))

27
src/code/early-constants.lisp Normal file
View file

@ -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."))

62
src/code/early-extensions.lisp
View file

@ -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."))

4
src/code/eval.lisp
View file

@ -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

4
src/code/late-extensions.lisp
View file

@ -124,9 +124,9 @@ 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

13
src/code/symbol.lisp
View file

@ -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.

1
src/code/target-alieneval.lisp
View file

@ -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)))))

2
src/code/target-package.lisp
View file

@ -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,

2
src/compiler/constantp.lisp
View file

@ -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

115
src/compiler/defconstant.lisp
View file

@ -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)

14
src/compiler/early-c.lisp
View file

@ -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

1
src/compiler/generic/genesis.lisp
View file

@ -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

4
src/compiler/generic/vm-macs.lisp
View file

@ -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)

18
src/compiler/globaldb.lisp
View file

@ -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

10
src/compiler/ir1-translators.lisp
View file

@ -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

18
src/compiler/ir1tran.lisp
View file

@ -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

63
src/compiler/ir1util.lisp
View file

@ -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

10
src/compiler/ir2tran.lisp
View file

@ -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

24
src/compiler/ltn.lisp
View file

@ -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

14
src/compiler/main.lisp
View file

@ -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*)

14
src/compiler/node.lisp
View file

@ -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)

8
src/compiler/proclaim.lisp
View file

@ -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))))

5
src/pcl/walk.lisp
View file

@ -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

93
tests/compiler.impure.lisp
View file

@ -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

6
tests/info.before-xc.lisp
View file

@ -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")

2
version.lisp-expr
View file

@ -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"