From 79a8e51bf4b06a5bd57bc90233605f98fee3b041 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 8 May 2009 19:08:07 +0000 Subject: [PATCH] 1.0.28.30: DEFGLOBAL, ALWAYS-BOUND, GLOBAL, SYMBOL-GLOBAL-VALUE * ALWAYS-BOUND allows the compiler to elide boundness checks for symbol value access, and prohibits MAKUNBOUND. This is handled via a new globaldb entry. GLOBAL makes the compiler elide TLS checking for symbol values access, and prohibits rebinding. This is handled via new globaldb :variable :type, namely :global. DEFGLOBAL is build on top of these. Global variables are mainly an efficiency measure on threaded builds, but can also express intention as they prohibit rebinding. * Add %SET-SYMBOL-GLOBAL-VALUE, FAST-SYMBOL-GLOBAL-VALUE, and SYMBOL-GLOBAL-VALUE VOPs to all backends. On unithreaded builds these are trivial copies of the non-global versions. * Tell SB-CLTL2 about both GLOBAL and ALWAYS-BOUND declarations too. * Document in the Efficiency chapter of the manual. * Prohibit declaring constants special. * Tests. Later: use these new features inside SBCL itself. For now there is only a single DEFGLOBAL used, but more could well be. --- NEWS | 10 ++ contrib/sb-cltl2/env.lisp | 24 +++-- contrib/sb-cltl2/tests.lisp | 13 ++- doc/manual/efficiency.texinfo | 39 +++++++- package-data-list.lisp-expr | 9 +- src/code/array.lisp | 30 +++--- src/code/defboot.lisp | 2 +- src/code/defsetfs.lisp | 1 + src/code/describe.lisp | 5 +- src/code/early-extensions.lisp | 62 +++++++----- src/code/eval.lisp | 2 +- src/code/full-eval.lisp | 5 +- src/code/gc.lisp | 3 - src/code/late-extensions.lisp | 41 +++++++- src/code/macros.lisp | 25 ++--- src/code/room.lisp | 3 + src/code/symbol.lisp | 18 +++- src/compiler/alpha/cell.lisp | 7 ++ src/compiler/debug.lisp | 2 +- src/compiler/defconstant.lisp | 4 +- src/compiler/fndb.lisp | 3 + src/compiler/fopcompile.lisp | 13 +-- src/compiler/generic/objdef.lisp | 4 +- src/compiler/globaldb.lisp | 10 +- src/compiler/hppa/cell.lisp | 6 ++ src/compiler/ir1-translators.lisp | 12 +-- src/compiler/ir1tran-lambda.lisp | 9 +- src/compiler/ir1tran.lisp | 17 +++- src/compiler/ir2tran.lisp | 21 ++-- src/compiler/mips/cell.lisp | 7 ++ src/compiler/node.lisp | 2 +- src/compiler/ppc/cell.lisp | 7 ++ src/compiler/proclaim.lisp | 31 +++++- src/compiler/sparc/cell.lisp | 7 ++ src/compiler/x86-64/cell.lisp | 151 ++++++++++++++-------------- src/compiler/x86/cell.lisp | 143 +++++++++++++-------------- tests/defglobal.impure.lisp | 196 +++++++++++++++++++++++++++++++++++++ tests/macroexpand.impure.lisp | 4 +- version.lisp-expr | 2 +- 39 files changed, 679 insertions(+), 271 deletions(-) create mode 100644 tests/defglobal.impure.lisp diff --git a/NEWS b/NEWS index 31d6f03..2e4ae83 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,13 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- + * new feature: SB-EXT:DEFGLOBAL macro allows defining global non-special + variables. + * new feature: SB-EXT:ALWAYS-BOUND proclamation inhibits MAKUNBOUND, and + allows the compiler to safely elide boundedness checks for special + variables. + * new feature: SB-EXT:GLOBAL proclamation inhibits SPECIAL proclamations for + the symbol, prohibits both lexical and dynamic binding. This is mainly an + efficiency measure for threaded platforms, but also valueable in + expressing intent. * optimization: compiler now generates faster array typechecking code. * optimization: ARRAY-DIMENSION is now faster for multidimensional and non-simple arrays. @@ -25,6 +34,7 @@ Mösenlechner) * bug fix: the value of CL:- in the inspector was the previous expression evaluated rather than the expression being evaluated. + * bug fix: constants can no longer be locally declared special. changes in sbcl-1.0.28 relative to 1.0.27: * a number of bugs in cross-compilation have been fixed, with the ultimate diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp index 9a0d2f4..dd9efd5 100644 --- a/contrib/sb-cltl2/env.lisp +++ b/contrib/sb-cltl2/env.lisp @@ -111,7 +111,7 @@ CARS of the alist include: (declaim (ftype (sfunction (symbol &optional (or null lexenv)) - (values (member nil :special :lexical :symbol-macro :constant) + (values (member nil :special :lexical :symbol-macro :constant :global) boolean list)) variable-information)) @@ -138,6 +138,9 @@ binding: NAME refers to a named constant defined using DEFCONSTANT, or NAME is a keyword. + :GLOBAL + NAME refers to a global variable. (SBCL specific extension.) + The second value is true if NAME is bound locally. This is currently always NIL for special variables, although arguably it should be T when there is a lexically apparent binding for the special variable. @@ -159,8 +162,12 @@ CARS of the alist include: T if there is explicit type declaration or proclamation associated with NAME. The type specifier may be equivalent to or a supertype of the original declaration. If the CDR is T the alist element may - be omitted." + be omitted. + +Additionally, the SBCL specific SB-EXT:ALWAYS-BOUND declaration will +appear with CDR as T if the variable has been declared always bound." (let* ((*lexenv* (or env (make-null-lexenv))) + (kind (info :variable :kind name)) (var (lexenv-find name vars)) binding localp dx ignorep type) (etypecase var @@ -181,8 +188,10 @@ CARS of the alist include: ;; -- though it is _possible_ to declare them ignored, but ;; we don't keep the information around. (sb-c::global-var - (setf binding :special - ;; FIXME: Lexically apparent binding or not? + (setf binding (if (eq :global kind) + :global + :special) + ;; FIXME: Lexically apparent binding or not for specials? localp nil)) (sb-c::constant (setf binding :constant @@ -191,11 +200,10 @@ CARS of the alist include: (setf binding :symbol-macro localp t)) (null - (let ((global-type (info :variable :type name)) - (kind (info :variable :kind name))) + (let ((global-type (info :variable :type name))) (setf binding (case kind (:macro :symbol-macro) - (:global nil) + (:unknown nil) (t kind)) type (if (eq *universal-type* global-type) nil @@ -208,6 +216,8 @@ CARS of the alist include: (when (and type (neq *universal-type* type)) (push (cons 'type (type-specifier type)) alist)) (when dx (push (cons 'dynamic-extent t) alist)) + (when (info :variable :always-bound name) + (push (cons 'sb-ext:always-bound t) alist)) alist)))) (declaim (ftype (sfunction (symbol &optional (or null lexenv)) t) diff --git a/contrib/sb-cltl2/tests.lisp b/contrib/sb-cltl2/tests.lisp index 0788260..ec5e8c9 100644 --- a/contrib/sb-cltl2/tests.lisp +++ b/contrib/sb-cltl2/tests.lisp @@ -6,7 +6,7 @@ ;;;; more information. (defpackage :sb-cltl2-tests - (:use :sb-cltl2 :cl :sb-rt)) + (:use :sb-cltl2 :cl :sb-rt :sb-ext)) (in-package :sb-cltl2-tests) @@ -209,6 +209,16 @@ (var-info #:undefined) (nil nil nil)) +(declaim (global this-is-global)) +(deftest global-variable + (var-info this-is-global) + (:global nil nil)) + +(defglobal this-is-global-too 42) +(deftest global-variable.2 + (var-info this-is-global-too) + (:global nil ((always-bound . t)))) + ;;;; FUNCTION-INFORMATION (defmacro fun-info (var &environment env) @@ -269,4 +279,3 @@ (fun-info identity)) (:function nil ((inline . inline) (ftype function (t) (values t &optional))))) - diff --git a/doc/manual/efficiency.texinfo b/doc/manual/efficiency.texinfo index b6d67fe..c03c733 100644 --- a/doc/manual/efficiency.texinfo +++ b/doc/manual/efficiency.texinfo @@ -4,10 +4,11 @@ @cindex Efficiency @menu -* Slot access:: -* Dynamic-extent allocation:: -* Modular arithmetic:: -* Miscellaneous Efficiency Issues:: +* Slot access:: +* Dynamic-extent allocation:: +* Modular arithmetic:: +* Global and Always-Bound variables:: +* Miscellaneous Efficiency Issues:: @end menu @node Slot access @@ -223,6 +224,36 @@ argument. ``Good'' widths are 32 on HPPA, MIPS, PPC, Sparc and x86 and 64 on Alpha. While it is possible to support smaller widths as well, currently this is not implemented. +@node Global and Always-Bound variables +@comment node-name, next, previous, up +@section Global and Always-Bound variables + +@include macro-sb-ext-defglobal.texinfo + +@deftp {Declaration} sb-ext:global + +Syntax: @code{(sb-ext:global symbol*)} + +Only valid as a global proclamation. + +Specifies that the named symbols cannot be proclaimed or locally +declared @code{special}. Proclaiming an already special or constant +variable name as @code{global} signal an error. Allows more efficient +value lookup in threaded environments in addition to expressing +programmer intention. +@end deftp + +@deftp {Declaration} sb-ext:always-bound + +Syntax: @code{(sb-ext:always-bound symbol*)} + +Only valid as a global proclamation. + +Specifies that the named symbols is always bound. Inhibits @code{makunbound} +of the named symbols. Proclaiming an unbound symbol as @code{always-bound} signals +an error. Allows compiler to elide boundness checks from value lookups. +@end deftp + @node Miscellaneous Efficiency Issues @comment node-name, next, previous, up @section Miscellaneous Efficiency Issues diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 12d0dc2..d7c2c58 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -265,6 +265,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "ENTRY-NODE-INFO-NLX-TAG" "ENTRY-NODE-INFO-ST-TOP" "PHYSENV-DEBUG-LIVE-TN" "PHYSENV-LIVE-TN" "FAST-SYMBOL-VALUE" + "FAST-SYMBOL-GLOBAL-VALUE" "FIND-SAVED-FP-AND-PC" "FIXUP-NOTE-KIND" "FIXUP-NOTE-FIXUP" @@ -630,6 +631,10 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "DEFCONSTANT-UNEQL" "DEFCONSTANT-UNEQL-NAME" "DEFCONSTANT-UNEQL-NEW-VALUE" "DEFCONSTANT-UNEQL-OLD-VALUE" + ;; global lexicals, access to global symbol values + "DEFGLOBAL" + "SYMBOL-GLOBAL-VALUE" + ;; package-locking stuff #!+sb-package-locks "PACKAGE-LOCKED-P" #!+sb-package-locks "LOCK-PACKAGE" @@ -665,7 +670,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "*MUFFLED-WARNINGS*" ;; extended declarations.. - "FREEZE-TYPE" "INHIBIT-WARNINGS" + "ALWAYS-BOUND" "FREEZE-TYPE" "GLOBAL" "INHIBIT-WARNINGS" "MAYBE-INLINE" ;; ..and variables to control compiler policy @@ -1694,7 +1699,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "INFINITE-ERROR-PROTECT" "FIND-CALLER-NAME-AND-FRAME" "FIND-INTERRUPTED-NAME-AND-FRAME" - "%SET-SYMBOL-VALUE" "%SET-SYMBOL-PACKAGE" + "%SET-SYMBOL-VALUE" "%SET-SYMBOL-GLOBAL-VALUE" "%SET-SYMBOL-PACKAGE" "OUTPUT-SYMBOL-NAME" "%COERCE-NAME-TO-FUN" "INVOKE-MACROEXPAND-HOOK" "DEFAULT-STRUCTURE-PRINT" "LAYOUT" "LAYOUT-LENGTH" "LAYOUT-PURE" "DSD-RAW-TYPE" diff --git a/src/code/array.lisp b/src/code/array.lisp index daedf8a..4cd1b08 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -328,19 +328,17 @@ of specialized arrays is supported." ;;; vectors or not simple. (macrolet ((def (name table-name) `(progn - (defvar ,table-name) + (defglobal ,table-name (make-array ,sb!vm:widetag-mask)) (defmacro ,name (array-var) - `(the function - (let ((tag 0)) - (when (sb!vm::%other-pointer-p ,array-var) - (setf tag (%other-pointer-widetag ,array-var))) - ;; SYMBOL-GLOBAL-VALUE is a performance hack - ;; for threaded builds. - (svref (sb!vm::symbol-global-value ',',table-name) tag))))))) - (def !find-data-vector-setter *data-vector-setters*) - (def !find-data-vector-setter/check-bounds *data-vector-setters/check-bounds*) - (def !find-data-vector-reffer *data-vector-reffers*) - (def !find-data-vector-reffer/check-bounds *data-vector-reffers/check-bounds*)) + `(the function + (let ((tag 0)) + (when (sb!vm::%other-pointer-p ,array-var) + (setf tag (%other-pointer-widetag ,array-var))) + (svref ,',table-name tag))))))) + (def !find-data-vector-setter **data-vector-setters**) + (def !find-data-vector-setter/check-bounds **data-vector-setters/check-bounds**) + (def !find-data-vector-reffer **data-vector-reffers**) + (def !find-data-vector-reffer/check-bounds **data-vector-reffers/check-bounds**)) (macrolet ((%ref (accessor-getter extra-params) `(funcall (,accessor-getter array) array index ,@extra-params)) @@ -445,16 +443,16 @@ of specialized arrays is supported." collect `(setf (svref ,symbol ,widetag) (,deffer ,saetp ,check-form)))))) (defun !hairy-data-vector-reffer-init () - (define-reffers *data-vector-reffers* define-reffer + (define-reffers **data-vector-reffers** define-reffer (progn) #'slow-hairy-data-vector-ref) - (define-reffers *data-vector-setters* define-setter + (define-reffers **data-vector-setters** define-setter (progn) #'slow-hairy-data-vector-set) - (define-reffers *data-vector-reffers/check-bounds* define-reffer + (define-reffers **data-vector-reffers/check-bounds** define-reffer (%check-bound vector (length vector)) #'slow-hairy-data-vector-ref/check-bounds) - (define-reffers *data-vector-setters/check-bounds* define-setter + (define-reffers **data-vector-setters/check-bounds** define-setter (%check-bound vector (length vector)) #'slow-hairy-data-vector-set/check-bounds))) diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 6642fc2..c09818e 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -249,7 +249,7 @@ evaluated as a PROGN." (defmacro-mundanely defvar (var &optional (val nil valp) (doc nil docp)) #!+sb-doc - "Define a global variable at top level. Declare the variable + "Defines a special variable at top level. Declare the variable SPECIAL and, optionally, initialize it. If the variable already has a value, the old value is not clobbered. The third argument is an optional documentation string for the variable." diff --git a/src/code/defsetfs.lisp b/src/code/defsetfs.lisp index dbd6db4..9ec31bc 100644 --- a/src/code/defsetfs.lisp +++ b/src/code/defsetfs.lisp @@ -107,6 +107,7 @@ (defsetf %array-dimension %set-array-dimension) (defsetf sb!kernel:%vector-raw-bits sb!kernel:%set-vector-raw-bits) #-sb-xc-host (defsetf symbol-value set) +#-sb-xc-host (defsetf symbol-global-value set-symbol-global-value) #-sb-xc-host (defsetf symbol-plist %set-symbol-plist) #-sb-xc-host (defsetf nth %setnth) #-sb-xc-host (defsetf fill-pointer %set-fill-pointer) diff --git a/src/code/describe.lisp b/src/code/describe.lisp index 67e45b5..7da9cd7 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -312,7 +312,8 @@ (:special "special variable") (:macro "symbol macro") (:constant "constant") - (:global "undefined variable") + (:global "global variable") + (:unknown "undefined variable") (:alien nil)))) (pprint-logical-block (s nil) (cond @@ -330,7 +331,7 @@ ((boundp x) (format s "~&~@" wot (symbol-value x))) - ((not (eq kind :global)) + ((not (eq kind :unknown)) (format s "~&~@" wot))) (when (eq (info :variable :where-from x) :declared) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 0e1d52a..ff13946 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -769,33 +769,43 @@ ;;; foo => 13, (constantp 'foo) => t ;;; ;;; ...in which case you frankly deserve to lose. -(defun about-to-modify-symbol-value (symbol action &optional (new-value nil valuep)) +(defun about-to-modify-symbol-value (symbol action &optional (new-value nil valuep) bind) (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))) - (when valuep - ;; :VARIABLE :TYPE is in the db only if it is declared, so no need to - ;; check. - (let ((type (info :variable :type symbol))) - (unless (sb!kernel::%%typep new-value type nil) - (let ((spec (type-specifier type))) - (error 'simple-type-error - :format-control "Cannot ~@? to ~S (not of type ~S.)" - :format-arguments (list action symbol new-value spec) - :datum new-value - :expected-type spec)))))) + (flet ((describe-action () + (ecase action + (set "set SYMBOL-VALUE of ~S") + (progv "bind ~S") + (compare-and-swap "compare-and-swap SYMBOL-VALUE of ~S") + (defconstant "define ~S as a constant") + (makunbound "make ~S unbound")))) + (let ((kind (info :variable :kind symbol))) + (multiple-value-bind (what continue) + (cond ((eq :constant kind) + (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)))) + ((and bind (eq :global kind)) + (values "Can't ~@? (global variable)." nil))) + (when what + (if continue + (cerror "Modify the constant." what (describe-action) symbol) + (error what (describe-action) symbol))) + (when valuep + ;; :VARIABLE :TYPE is in the db only if it is declared, so no need to + ;; check. + (let ((type (info :variable :type symbol))) + (unless (sb!kernel::%%typep new-value type nil) + (let ((spec (type-specifier type))) + (error 'simple-type-error + :format-control "Cannot ~@? to ~S (not of type ~S.)" + :format-arguments (list action (describe-action) new-value spec) + :datum new-value + :expected-type spec)))))))) (values)) ;;; If COLD-FSET occurs not at top level, just treat it as an ordinary diff --git a/src/code/eval.lisp b/src/code/eval.lisp index f639dd7..ac9718f 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -130,7 +130,7 @@ (typecase exp (symbol (ecase (info :variable :kind exp) - ((:special :global :constant) + ((:special :global :constant :unknown) (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/full-eval.lisp b/src/code/full-eval.lisp index 6f6a88f..00e4e33 100644 --- a/src/code/full-eval.lisp +++ b/src/code/full-eval.lisp @@ -236,7 +236,10 @@ (cond ((eq type :constant) ;; Horrible place for this, but it works. - (ip-error "Can't bind constant symbol ~S" symbol)) + (ip-error "Can't bind constant symbol: ~S" symbol)) + ((eq type :global) + ;; Ditto... + (ip-error "Can't bind a global variable: ~S" symbol)) ((eq type :special) t) ((member symbol declared-specials :test #'eq) t) diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 8a8fe46..c128995 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -13,9 +13,6 @@ ;;;; DYNAMIC-USAGE and friends -(declaim (special sb!vm:*read-only-space-free-pointer* - sb!vm:*static-space-free-pointer*)) - (eval-when (:compile-toplevel :execute) (sb!xc:defmacro def-c-var-fun (lisp-fun c-var-name) `(defun ,lisp-fun () diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp index 0d1febe..e72769f 100644 --- a/src/code/late-extensions.lisp +++ b/src/code/late-extensions.lisp @@ -108,7 +108,7 @@ EXPERIMENTAL: Interface subject to change." (,n-old ,old) (,n-new ,new)) (declare (symbol ,n-symbol)) - (about-to-modify-symbol-value ,n-symbol "compare-and-swap SYMBOL-VALUE of ~S" ,n-new) + (about-to-modify-symbol-value ,n-symbol 'compare-and-swap ,n-new) (%compare-and-swap-symbol-value ,n-symbol ,n-old ,n-new))))) (if (sb!xc:constantp name env) (let ((cname (constant-form-value name env))) @@ -230,3 +230,42 @@ EXPERIMENTAL: Interface subject to change." (warn "Problem running ~A hook ~S:~% ~A" kind hook c) (with-simple-restart (continue "Skip this ~A hook." kind) (error "Problem running ~A hook ~S:~% ~A" kind hook c))))))) + +;;;; DEFGLOBAL + +(defmacro-mundanely defglobal (name value &optional (doc nil docp)) + #!+sb-doc + "Defines NAME as a global variable that is always bound. VALUE is evaluated +and assigned to NAME both at compile- and load-time, but only if NAME is not +already bound. + +Global variables share their values between all threads, and cannot be +locally bound, declared special, defined as constants, and neither bound +nor defined as symbol macros. + +See also the declarations SB-EXT:GLOBAL and SB-EXT:ALWAYS-BOUND." + `(progn + (eval-when (:compile-toplevel) + (let ((boundp (boundp ',name))) + (%compiler-defglobal ',name (unless boundp ,value) boundp))) + (eval-when (:load-toplevel :execute) + (let ((boundp (boundp ',name))) + (%defglobal ',name (unless boundp ,value) boundp ',doc ,docp + (sb!c:source-location)))))) + +(defun %compiler-defglobal (name value boundp) + (sb!xc:proclaim `(global ,name)) + (unless boundp + #-sb-xc-host + (set-symbol-global-value name value) + #+sb-xc-host + (set name value)) + (sb!xc:proclaim `(always-bound ,name))) + +(defun %defglobal (name value boundp doc docp source-location) + (%compiler-defglobal name value boundp) + (when docp + (setf (fdocumentation name 'variable) doc)) + (sb!c:with-source-location (source-location) + (setf (info :source-location :variable name) source-location)) + name) diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 3c95c6e..f9f2bd3 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -99,18 +99,19 @@ invoked. In that case it will store into PLACE and start over." (:symbol name "defining ~A as a symbol-macro")) (sb!c:with-source-location (source-location) (setf (info :source-location :symbol-macro name) source-location)) - (ecase (info :variable :kind name) - ((:macro :global nil) - (setf (info :variable :kind name) :macro) - (setf (info :variable :macro-expansion name) expansion)) - (:special - (error 'simple-program-error - :format-control "Symbol macro name already declared special: ~S." - :format-arguments (list name))) - (:constant - (error 'simple-program-error - :format-control "Symbol macro name already declared constant: ~S." - :format-arguments (list name)))) + (let ((kind (info :variable :kind name))) + (ecase kind + ((:macro :unknown) + (setf (info :variable :kind name) :macro) + (setf (info :variable :macro-expansion name) expansion)) + ((:special :global) + (error 'simple-program-error + :format-control "Symbol macro name already declared ~A: ~S." + :format-arguments (list kind name))) + (:constant + (error 'simple-program-error + :format-control "Symbol macro name already defined as a constant: ~S." + :format-arguments (list name))))) name) ;;;; DEFINE-COMPILER-MACRO diff --git a/src/code/room.lisp b/src/code/room.lisp index 7e05a7e..328ca45 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -10,6 +10,9 @@ ;;;; files for more information. (in-package "SB!VM") + +(declaim (special sb!vm:*read-only-space-free-pointer* + sb!vm:*static-space-free-pointer*)) ;;;; type format database diff --git a/src/code/symbol.lisp b/src/code/symbol.lisp index 58f3fc1..c95370f 100644 --- a/src/code/symbol.lisp +++ b/src/code/symbol.lisp @@ -32,12 +32,24 @@ #!+sb-doc "Set SYMBOL's value cell to NEW-VALUE." (declare (type symbol symbol)) - (about-to-modify-symbol-value symbol "set SYMBOL-VALUE of ~S" new-value) + (about-to-modify-symbol-value symbol 'set new-value) (%set-symbol-value symbol new-value)) (defun %set-symbol-value (symbol new-value) (%set-symbol-value symbol new-value)) +(defun symbol-global-value (symbol) + #!+sb-doc + "Return the SYMBOL's current global value. Identical to SYMBOL-VALUE, +in single-threaded builds: in multithreaded builds bound values are +distinct from the global value. Can also be SETF." + (declare (optimize (safety 1))) + (symbol-global-value symbol)) + +(defun set-symbol-global-value (symbol new-value) + (about-to-modify-symbol-value symbol 'set new-value) + (sb!kernel:%set-symbol-global-value symbol new-value)) + (declaim (inline %makunbound)) (defun %makunbound (symbol) (%set-symbol-value symbol (%primitive sb!c:make-other-immediate-type @@ -47,7 +59,9 @@ #!+sb-doc "Make SYMBOL unbound, removing any value it may currently have." (with-single-package-locked-error (:symbol symbol "unbinding the symbol ~A") - (about-to-modify-symbol-value symbol "make ~S unbound") + (when (and (info :variable :always-bound symbol)) + (error "Can't make ~A variable unbound: ~S" 'always-bound symbol)) + (about-to-modify-symbol-value symbol 'makunbound) (%makunbound symbol) symbol)) diff --git a/src/compiler/alpha/cell.lisp b/src/compiler/alpha/cell.lisp index 4e80a7b..22f7ce6 100644 --- a/src/compiler/alpha/cell.lisp +++ b/src/compiler/alpha/cell.lisp @@ -100,6 +100,13 @@ ;; ensure this is explained in the comment in objdef.lisp (loadw res symbol symbol-hash-slot other-pointer-lowtag) (inst bic res #.(ash lowtag-mask -1) res))) + +;;; On unithreaded builds these are just copies of the non-global versions. +(define-vop (%set-symbol-global-value set)) +(define-vop (symbol-global-value symbol-value) + (:translate symbol-global-value)) +(define-vop (fast-symbol-global-value fast-symbol-value) + (:translate symbol-global-value)) ;;;; fdefinition (FDEFN) objects diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index 155b847..9c37ee1 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -122,7 +122,7 @@ (unless (or (constant-p v) (and (global-var-p v) (member (global-var-kind v) - '(:global :special)))) + '(:global :special :unknown)))) (barf "strange *FREE-VARS* entry: ~S" v)) (dolist (n (leaf-refs v)) (check-node-reached n)) diff --git a/src/compiler/defconstant.lisp b/src/compiler/defconstant.lisp index 1bb1d27..db7d628 100644 --- a/src/compiler/defconstant.lisp +++ b/src/compiler/defconstant.lisp @@ -43,7 +43,7 @@ (if (boundp name) (if (typep name '(or boolean keyword)) ;; Non-continuable error. - (about-to-modify-symbol-value name "define ~S as a constant") + (about-to-modify-symbol-value name 'defconstant) (let ((old (symbol-value name))) (unless (eql value old) (multiple-value-bind (ignore aborted) @@ -57,7 +57,7 @@ (when aborted (return-from sb!c::%defconstant name)))))) (warn "redefining a MAKUNBOUND constant: ~S" name))) - (:global + (:unknown ;; (This is OK -- undefined variables are of this kind. So we ;; don't warn or error or anything, just fall through.) ) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 6fb5eb8..08a5e0b 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1379,6 +1379,9 @@ ;;;; miscellaneous extensions +(defknown symbol-global-value (symbol) t ()) +(defknown set-symbol-global-value (symbol t) t ()) + (defknown get-bytes-consed () unsigned-byte (flushable)) (defknown mask-signed-field ((integer 0 *) integer) integer (movable flushable foldable)) diff --git a/src/compiler/fopcompile.lisp b/src/compiler/fopcompile.lisp index 4ea842f..b1cbefe 100644 --- a/src/compiler/fopcompile.lisp +++ b/src/compiler/fopcompile.lisp @@ -47,11 +47,7 @@ (fopcompilable-p macroexpansion) ;; Punt on :ALIEN variables (let ((kind (info :variable :kind form))) - (or (eq kind :special) - ;; Not really a global, but a variable for - ;; which no information exists. - (eq kind :global) - (eq kind :constant)))))) + (member kind '(:special :constant :global :unknown)))))) (and (listp form) (ignore-errors (list-length form)) (multiple-value-bind (macroexpansion macroexpanded-p) @@ -158,11 +154,10 @@ for value = (if (consp binding) (second binding) nil) - ;; Only allow binding lexicals, - ;; since special bindings can't be - ;; easily expressed with fops. + ;; Only allow binding locals, since special bindings can't + ;; be easily expressed with fops. always (and (eq (info :variable :kind name) - :global) + :unknown) (let ((*lexenv* (ecase operator (let orig-lexenv) (let* *lexenv*)))) diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index 6e9d5d4..e942b54 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -322,7 +322,9 @@ ;; first data slot, and if you subtract 7 you get a symbol header. ;; also the CAR of NIL-as-end-of-list - (value :init :unbound :ref-known (flushable) :ref-trans symbol-global-value) + (value :init :unbound + :set-trans %set-symbol-global-value + :set-known (unsafe)) ;; also the CDR of NIL-as-end-of-list. Its reffer needs special ;; care for this reason, as hash values must be fixnums. (hash :set-trans %set-symbol-hash) diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index 50a425e..56fc8c2 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -1059,10 +1059,16 @@ (define-info-type :class :variable :type :kind - :type-spec (member :special :constant :macro :global :alien) + :type-spec (member :special :constant :macro :global :alien :unknown) :default (if (typep name '(or boolean keyword)) :constant - :global)) + :unknown)) + +(define-info-type + :class :variable + :type :always-bound + :type-spec boolean + :default nil) ;;; the declared type for this variable (define-info-type diff --git a/src/compiler/hppa/cell.lisp b/src/compiler/hppa/cell.lisp index a58ae4e..bd52535 100644 --- a/src/compiler/hppa/cell.lisp +++ b/src/compiler/hppa/cell.lisp @@ -92,6 +92,12 @@ ;; we must go through an temporary to avoid gc (move temp res))) +;;; On unithreaded builds these are just copies of the non-global versions. +(define-vop (%set-symbol-global-value set)) +(define-vop (symbol-global-value symbol-value) + (:translate symbol-global-value)) +(define-vop (fast-symbol-global-value fast-symbol-value) + (:translate symbol-global-value)) ;;;; Fdefinition (fdefn) objects. diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 885f5d2..7556b7e 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -373,7 +373,7 @@ destructuring lambda list, and the FORMS evaluate to the expansion." (program-assert-symbol-home-package-unlocked context name "binding ~A as a local symbol-macro")) (let ((kind (info :variable :kind name))) - (when (member kind '(:special :constant)) + (when (member kind '(:special :constant :global)) (fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" kind name))) ;; A magical cons that MACROEXPAND-1 understands. @@ -509,9 +509,9 @@ Return VALUE without evaluating it." (dolist (lambda lambdas) (setf (functional-allocator lambda) allocator))))) -(defmacro with-fun-name-leaf ((leaf thing start &key global) &body body) +(defmacro with-fun-name-leaf ((leaf thing start &key global-function) &body body) `(multiple-value-bind (,leaf allocate-p) - (if ,global + (if ,global-function (find-global-fun ,thing t) (fun-name-leaf ,thing)) (if allocate-p @@ -535,7 +535,7 @@ be a lambda expression." ;;; expansions, and doesn't nag about undefined functions. ;;; Used for optimizing things like (FUNCALL 'FOO). (def-ir1-translator global-function ((thing) start next result) - (with-fun-name-leaf (leaf thing start :global t) + (with-fun-name-leaf (leaf thing start :global-function t) (reference-leaf start next result leaf))) (defun constant-global-fun-name (thing) @@ -592,7 +592,7 @@ be a lambda expression." (with-fun-name-leaf (leaf (second function) start) (ir1-convert start next result `(,leaf ,@args)))) ((eq op 'global-function) - (with-fun-name-leaf (leaf (second function) start :global t) + (with-fun-name-leaf (leaf (second function) start :global-function t) (ir1-convert start next result `(,leaf ,@args)))) (t (let ((ctran (make-ctran)) @@ -937,7 +937,7 @@ care." (compiler-style-warn "~S is being set even though it was declared to be ignored." name))) - (if (and (global-var-p leaf) (eq :global (global-var-kind leaf))) + (if (and (global-var-p leaf) (eq :unknown (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)) diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index b107a41..efe3a48 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -33,9 +33,12 @@ (compiler-error "The variable ~S occurs more than once in the lambda list." name)) (let ((kind (info :variable :kind name))) - (when (or (keywordp name) (eq kind :constant)) - (compiler-error "The name of the lambda variable ~S is already in use to name a constant." - name)) + (cond ((or (keywordp name) (eq kind :constant)) + (compiler-error "The name of the lambda variable ~S is already in use to name a constant." + name)) + ((eq :global kind) + (compiler-error "The name of the lambda variable ~S is already in use to name a global variable." + name))) (cond ((eq kind :special) (let ((specvar (find-free-var name))) (make-lambda-var :%source-name name diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 044097a..ac16a1d 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -241,7 +241,7 @@ (let ((kind (info :variable :kind name)) (type (info :variable :type name)) (where-from (info :variable :where-from name))) - (when (and (eq where-from :assumed) (eq kind :global)) + (when (eq kind :unknown) (note-undefined-reference name :variable)) (setf (gethash name *free-vars*) (case kind @@ -639,7 +639,10 @@ ;; KLUDGE: If the reference is dead, convert using SYMBOL-VALUE ;; which is not flushable, so that unbound dead variables signal ;; an error (bug 412). - (ir1-convert start next result `(symbol-value ',name)) + (ir1-convert start next result + (if (eq (global-var-kind var) :global) + `(symbol-global-value ',name) + `(symbol-value ',name))) (etypecase var (leaf (when (lambda-var-p var) @@ -1212,6 +1215,16 @@ (declare (list spec vars) (type lexenv res)) (collect ((new-venv nil cons)) (dolist (name (cdr spec)) + ;; While CLHS seems to allow local SPECIAL declarations for constants, + ;; whatever the semantics are supposed to be is not at all clear to me + ;; -- since constants aren't allowed to be bound it should be a no-op as + ;; no-one can observe the difference portably, but specials are allowed + ;; to be bound... yet nowhere does it say that the special declaration + ;; removes the constantness. Call it a spec bug and prohibit it. Same + ;; for GLOBAL variables. + (let ((kind (info :variable :kind name))) + (unless (member kind '(:special :unknown)) + (error "Can't declare ~(~A~) variable locally special: ~S" kind name))) (program-assert-symbol-home-package-unlocked context name "declaring ~A special") (let ((var (find-in-bindings vars name))) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index ea5e1d9..cc74cca 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -141,12 +141,18 @@ (let ((unsafe (policy node (zerop safety))) (name (leaf-source-name leaf))) (ecase (global-var-kind leaf) - ((:special :global) + ((:special :unknown) (aver (symbolp name)) (let ((name-tn (emit-constant name))) - (if unsafe + (if (or unsafe (info :variable :always-bound name)) (vop fast-symbol-value node block name-tn res) (vop symbol-value node block name-tn res)))) + (:global + (aver (symbolp name)) + (let ((name-tn (emit-constant name))) + (if (or unsafe (info :variable :always-bound name)) + (vop fast-symbol-global-value node block name-tn res) + (vop symbol-global-value node block name-tn res)))) (:global-function (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name))) (if unsafe @@ -298,10 +304,13 @@ (vop value-cell-set node block tn val) (emit-move node block val tn))))) (global-var + (aver (symbolp (leaf-source-name leaf))) (ecase (global-var-kind leaf) ((:special) - (aver (symbolp (leaf-source-name leaf))) - (vop set node block (emit-constant (leaf-source-name leaf)) val))))) + (vop set node block (emit-constant (leaf-source-name leaf)) val)) + ((:global) + (vop %set-symbol-global-value node + block (emit-constant (leaf-source-name leaf)) val))))) (when locs (emit-move node block val (first locs)) (move-lvar-result node block locs lvar))) @@ -1452,7 +1461,7 @@ (dolist (var vars) ;; CLHS says "bound and then made to have no value" -- user ;; should not be able to tell the difference between that and this. - (about-to-modify-symbol-value var "bind ~S") + (about-to-modify-symbol-value var 'progv) (%primitive bind unbound-marker var)))) (,bind (vars vals) (declare (optimize (speed 2) (debug 0) @@ -1462,7 +1471,7 @@ (t (let ((val (car vals)) (var (car vars))) - (about-to-modify-symbol-value var "bind ~S" val) + (about-to-modify-symbol-value var 'progv val t) (%primitive bind val var)) (,bind (cdr vars) (cdr vals)))))) (,bind ,vars ,vals)) diff --git a/src/compiler/mips/cell.lisp b/src/compiler/mips/cell.lisp index 4ba16b8..0d32080 100644 --- a/src/compiler/mips/cell.lisp +++ b/src/compiler/mips/cell.lisp @@ -102,6 +102,13 @@ (loadw temp symbol symbol-hash-slot other-pointer-lowtag) (inst srl temp n-fixnum-tag-bits) (inst sll res temp n-fixnum-tag-bits))) + +;;; On unithreaded builds these are just copies of the non-global versions. +(define-vop (%set-symbol-global-value set)) +(define-vop (symbol-global-value symbol-value) + (:translate symbol-global-value)) +(define-vop (fast-symbol-global-value fast-symbol-value) + (:translate symbol-global-value)) ;;;; Fdefinition (fdefn) objects. diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index cb167fd..ceb1a2b 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -689,7 +689,7 @@ (def!struct (global-var (:include basic-var)) ;; kind of variable described (kind (missing-arg) - :type (member :special :global-function :global))) + :type (member :special :global-function :global :unknown))) (defprinter (global-var :identity t) %source-name #!+sb-show id diff --git a/src/compiler/ppc/cell.lisp b/src/compiler/ppc/cell.lisp index d44dc85..00bff09 100644 --- a/src/compiler/ppc/cell.lisp +++ b/src/compiler/ppc/cell.lisp @@ -92,6 +92,13 @@ ;; ensure this is explained in the comment in objdef.lisp (loadw res symbol symbol-hash-slot other-pointer-lowtag) (inst clrrwi res res n-fixnum-tag-bits))) + +;;; On unithreaded builds these are just copies of the non-global versions. +(define-vop (%set-symbol-global-value set)) +(define-vop (symbol-global-value symbol-value) + (:translate symbol-global-value)) +(define-vop (fast-symbol-global-value fast-symbol-value) + (:translate symbol-global-value)) ;;;; Fdefinition (fdefn) objects. diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 7ebf666..acaa660 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -170,14 +170,35 @@ (kind (first form)) (args (rest form))) (case kind - (special + ((special global) + (flet ((make-special (name old) + (unless (member old '(:special :unknown)) + (error "Cannot proclaim a ~(~A~) variable special: ~S" old name)) + (with-single-package-locked-error + (:symbol name "globally declaring ~A special") + (setf (info :variable :kind name) :special))) + (make-global (name old) + (unless (member old '(:global :unknown)) + (error "Cannot proclaim a ~(~A~) variable global: ~S" old name)) + (with-single-package-locked-error + (:symbol name "globally declaring ~A global") + (setf (info :variable :kind name) :global)))) + (let ((fun (if (eq 'special kind) #'make-special #'make-global))) + (dolist (name args) + (unless (symbolp name) + (error "Can't declare a non-symbol as ~S: ~S" kind name)) + (funcall fun name (info :variable :kind name)))))) + (always-bound (dolist (name args) (unless (symbolp name) - (error "can't declare a non-symbol as SPECIAL: ~S" name)) + (error "Can't proclaim a non-symbol as ~S: ~S" kind name)) + (unless (boundp name) + (error "Can't proclaim an unbound symbol as ~S: ~S" kind name)) + (when (eq :constant (info :variable :kind name)) + (error "Can't proclaim a constant variable as ~S: ~S" kind name)) (with-single-package-locked-error - (:symbol name "globally declaring ~A special") - (about-to-modify-symbol-value name "proclaim ~S as SPECIAL") - (setf (info :variable :kind name) :special)))) + (:symbol name "globally declaring ~A always bound") + (setf (info :variable :always-bound name) t)))) (type (if *type-system-initialized* (let ((type (specifier-type (first args)))) diff --git a/src/compiler/sparc/cell.lisp b/src/compiler/sparc/cell.lisp index 8767f02..20a4a5b 100644 --- a/src/compiler/sparc/cell.lisp +++ b/src/compiler/sparc/cell.lisp @@ -92,6 +92,13 @@ ;; ensure this is explained in the comment in objdef.lisp (loadw res symbol symbol-hash-slot other-pointer-lowtag) (inst andn res res fixnum-tag-mask))) + +;;; On unithreaded builds these are just copies of the non-global versions. +(define-vop (%set-symbol-global-value set)) +(define-vop (symbol-global-value symbol-value) + (:translate symbol-global-value)) +(define-vop (fast-symbol-global-value fast-symbol-value) + (:translate symbol-global-value)) ;;;; FDEFINITION (fdefn) objects. (define-vop (fdefn-fun cell-ref) diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp index 3f2b590..b7687f7 100644 --- a/src/compiler/x86-64/cell.lisp +++ b/src/compiler/x86-64/cell.lisp @@ -104,84 +104,17 @@ (inst cmp result unbound-marker-widetag) (inst jmp :e unbound)))) -;;; these next two cf the sparc version, by jrd. -;;; FIXME: Deref this ^ reference. - - -;;; The compiler likes to be able to directly SET symbols. -#!+sb-thread -(define-vop (set) - (:args (symbol :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) - (:temporary (:sc descriptor-reg) tls) - ;;(:policy :fast-safe) - (:generator 4 - (let ((global-val (gen-label)) - (done (gen-label))) - (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag) - (inst cmp (make-ea :qword :base thread-base-tn :scale 1 :index tls) - no-tls-value-marker-widetag) - (inst jmp :z global-val) - (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls) - value) - (inst jmp done) - (emit-label global-val) - (storew value symbol symbol-value-slot other-pointer-lowtag) - (emit-label done)))) - -;; unithreaded it's a lot simpler ... -#!-sb-thread -(define-vop (set cell-set) +(define-vop (%set-symbol-global-value cell-set) (:variant symbol-value-slot other-pointer-lowtag)) -;;; With Symbol-Value, we check that the value isn't the trap object. So -;;; Symbol-Value of NIL is NIL. -#!+sb-thread -(define-vop (symbol-value) - (:translate symbol-value) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:result 1))) - (:results (value :scs (descriptor-reg any-reg))) - (:vop-var vop) - (:save-p :compute-only) - (:generator 9 - (let* ((check-unbound-label (gen-label)) - (err-lab (generate-error-code vop 'unbound-symbol-error object)) - (ret-lab (gen-label))) - (loadw value object symbol-tls-index-slot other-pointer-lowtag) - (inst mov value (make-ea :qword :base thread-base-tn - :index value :scale 1)) - (inst cmp value no-tls-value-marker-widetag) - (inst jmp :ne check-unbound-label) - (loadw value object symbol-value-slot other-pointer-lowtag) - (emit-label check-unbound-label) - (inst cmp value unbound-marker-widetag) - (inst jmp :e err-lab) - (emit-label ret-lab)))) - -#!+sb-thread -(define-vop (fast-symbol-value symbol-value) - ;; KLUDGE: not really fast, in fact, because we're going to have to - ;; do a full lookup of the thread-local area anyway. But half of - ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if - ;; unbound", which is used in the implementation of COPY-SYMBOL. -- - ;; CSR, 2003-04-22 +(define-vop (fast-symbol-global-value cell-ref) + (:variant symbol-value-slot other-pointer-lowtag) (:policy :fast) - (:translate symbol-value) - (:generator 8 - (let ((ret-lab (gen-label))) - (loadw value object symbol-tls-index-slot other-pointer-lowtag) - (inst mov value - (make-ea :qword :base thread-base-tn :index value :scale 1)) - (inst cmp value no-tls-value-marker-widetag) - (inst jmp :ne ret-lab) - (loadw value object symbol-value-slot other-pointer-lowtag) - (emit-label ret-lab)))) + (:translate symbol-global-value)) -#!-sb-thread -(define-vop (symbol-value) - (:translate symbol-value) +(define-vop (symbol-global-value) (:policy :fast-safe) + (:translate symbol-global-value) (:args (object :scs (descriptor-reg) :to (:result 1))) (:results (value :scs (descriptor-reg any-reg))) (:vop-var vop) @@ -192,11 +125,75 @@ (inst cmp value unbound-marker-widetag) (inst jmp :e err-lab)))) +#!+sb-thread +(progn + (define-vop (set) + (:args (symbol :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:temporary (:sc descriptor-reg) tls) + (:generator 4 + (let ((global-val (gen-label)) + (done (gen-label))) + (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag) + (inst cmp (make-ea :qword :base thread-base-tn :scale 1 :index tls) + no-tls-value-marker-widetag) + (inst jmp :z global-val) + (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls) + value) + (inst jmp done) + (emit-label global-val) + (storew value symbol symbol-value-slot other-pointer-lowtag) + (emit-label done)))) + + ;; With Symbol-Value, we check that the value isn't the trap object. So + ;; Symbol-Value of NIL is NIL. + (define-vop (symbol-value) + (:translate symbol-value) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:result 1))) + (:results (value :scs (descriptor-reg any-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:generator 9 + (let* ((check-unbound-label (gen-label)) + (err-lab (generate-error-code vop 'unbound-symbol-error object)) + (ret-lab (gen-label))) + (loadw value object symbol-tls-index-slot other-pointer-lowtag) + (inst mov value (make-ea :qword :base thread-base-tn + :index value :scale 1)) + (inst cmp value no-tls-value-marker-widetag) + (inst jmp :ne check-unbound-label) + (loadw value object symbol-value-slot other-pointer-lowtag) + (emit-label check-unbound-label) + (inst cmp value unbound-marker-widetag) + (inst jmp :e err-lab) + (emit-label ret-lab)))) + + (define-vop (fast-symbol-value symbol-value) + ;; KLUDGE: not really fast, in fact, because we're going to have to + ;; do a full lookup of the thread-local area anyway. But half of + ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if + ;; unbound", which is used in the implementation of COPY-SYMBOL. -- + ;; CSR, 2003-04-22 + (:policy :fast) + (:translate symbol-value) + (:generator 8 + (let ((ret-lab (gen-label))) + (loadw value object symbol-tls-index-slot other-pointer-lowtag) + (inst mov value + (make-ea :qword :base thread-base-tn :index value :scale 1)) + (inst cmp value no-tls-value-marker-widetag) + (inst jmp :ne ret-lab) + (loadw value object symbol-value-slot other-pointer-lowtag) + (emit-label ret-lab))))) + #!-sb-thread -(define-vop (fast-symbol-value cell-ref) - (:variant symbol-value-slot other-pointer-lowtag) - (:policy :fast) - (:translate symbol-value)) +(progn + (define-vop (symbol-value symbol-global-value) + (:translate symbol-value)) + (define-vop (fast-symbol-value fast-symbol-global-value) + (:translate symbol-value)) + (define-vop (set %set-symbol-global-value))) #!+sb-thread (define-vop (boundp) diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp index 2857d95..2590000 100644 --- a/src/compiler/x86/cell.lisp +++ b/src/compiler/x86/cell.lisp @@ -84,80 +84,17 @@ (inst cmp result unbound-marker-widetag) (inst jmp :e unbound)))) -;;; these next two cf the sparc version, by jrd. -;;; FIXME: Deref this ^ reference. - - -;;; The compiler likes to be able to directly SET symbols. -#!+sb-thread -(define-vop (set) - (:args (symbol :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) - (:temporary (:sc descriptor-reg) tls) - ;;(:policy :fast-safe) - (:generator 4 - (let ((global-val (gen-label)) - (done (gen-label))) - (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag) - (inst cmp (make-ea :dword :base tls) no-tls-value-marker-widetag :fs) - (inst jmp :z global-val) - (inst mov (make-ea :dword :base tls) value :fs) - (inst jmp done) - (emit-label global-val) - (storew value symbol symbol-value-slot other-pointer-lowtag) - (emit-label done)))) - -;; unithreaded it's a lot simpler ... -#!-sb-thread -(define-vop (set cell-set) +(define-vop (%set-symbol-global-value cell-set) (:variant symbol-value-slot other-pointer-lowtag)) -;;; With Symbol-Value, we check that the value isn't the trap object. So -;;; Symbol-Value of NIL is NIL. -#!+sb-thread -(define-vop (symbol-value) - (:translate symbol-value) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:result 1))) - (:results (value :scs (descriptor-reg any-reg))) - (:vop-var vop) - (:save-p :compute-only) - (:generator 9 - (let* ((check-unbound-label (gen-label)) - (err-lab (generate-error-code vop 'unbound-symbol-error object)) - (ret-lab (gen-label))) - (loadw value object symbol-tls-index-slot other-pointer-lowtag) - (inst mov value (make-ea :dword :base value) :fs) - (inst cmp value no-tls-value-marker-widetag) - (inst jmp :ne check-unbound-label) - (loadw value object symbol-value-slot other-pointer-lowtag) - (emit-label check-unbound-label) - (inst cmp value unbound-marker-widetag) - (inst jmp :e err-lab) - (emit-label ret-lab)))) - -#!+sb-thread -(define-vop (fast-symbol-value symbol-value) - ;; KLUDGE: not really fast, in fact, because we're going to have to - ;; do a full lookup of the thread-local area anyway. But half of - ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if - ;; unbound", which is used in the implementation of COPY-SYMBOL. -- - ;; CSR, 2003-04-22 +(define-vop (fast-symbol-global-value cell-ref) + (:variant symbol-value-slot other-pointer-lowtag) (:policy :fast) - (:translate symbol-value) - (:generator 8 - (let ((ret-lab (gen-label))) - (loadw value object symbol-tls-index-slot other-pointer-lowtag) - (inst mov value (make-ea :dword :base value) :fs) - (inst cmp value no-tls-value-marker-widetag) - (inst jmp :ne ret-lab) - (loadw value object symbol-value-slot other-pointer-lowtag) - (emit-label ret-lab)))) + (:translate symbol-global-value)) -#!-sb-thread -(define-vop (symbol-value) - (:translate symbol-value) +(define-vop (symbol-global-value) (:policy :fast-safe) + (:translate symbol-global-value) (:args (object :scs (descriptor-reg) :to (:result 1))) (:results (value :scs (descriptor-reg any-reg))) (:vop-var vop) @@ -168,11 +105,71 @@ (inst cmp value unbound-marker-widetag) (inst jmp :e err-lab)))) +#!+sb-thread +(progn + (define-vop (set) + (:args (symbol :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:temporary (:sc descriptor-reg) tls) + (:generator 4 + (let ((global-val (gen-label)) + (done (gen-label))) + (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag) + (inst cmp (make-ea :dword :base tls) no-tls-value-marker-widetag :fs) + (inst jmp :z global-val) + (inst mov (make-ea :dword :base tls) value :fs) + (inst jmp done) + (emit-label global-val) + (storew value symbol symbol-value-slot other-pointer-lowtag) + (emit-label done)))) + + ;; With Symbol-Value, we check that the value isn't the trap object. So + ;; Symbol-Value of NIL is NIL. + (define-vop (symbol-value) + (:translate symbol-value) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:result 1))) + (:results (value :scs (descriptor-reg any-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:generator 9 + (let* ((check-unbound-label (gen-label)) + (err-lab (generate-error-code vop 'unbound-symbol-error object)) + (ret-lab (gen-label))) + (loadw value object symbol-tls-index-slot other-pointer-lowtag) + (inst mov value (make-ea :dword :base value) :fs) + (inst cmp value no-tls-value-marker-widetag) + (inst jmp :ne check-unbound-label) + (loadw value object symbol-value-slot other-pointer-lowtag) + (emit-label check-unbound-label) + (inst cmp value unbound-marker-widetag) + (inst jmp :e err-lab) + (emit-label ret-lab)))) + + (define-vop (fast-symbol-value symbol-value) + ;; KLUDGE: not really fast, in fact, because we're going to have to + ;; do a full lookup of the thread-local area anyway. But half of + ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if + ;; unbound", which is used in the implementation of COPY-SYMBOL. -- + ;; CSR, 2003-04-22 + (:policy :fast) + (:translate symbol-value) + (:generator 8 + (let ((ret-lab (gen-label))) + (loadw value object symbol-tls-index-slot other-pointer-lowtag) + (inst mov value (make-ea :dword :base value) :fs) + (inst cmp value no-tls-value-marker-widetag) + (inst jmp :ne ret-lab) + (loadw value object symbol-value-slot other-pointer-lowtag) + (emit-label ret-lab))))) + #!-sb-thread -(define-vop (fast-symbol-value cell-ref) - (:variant symbol-value-slot other-pointer-lowtag) - (:policy :fast) - (:translate symbol-value)) +(progn + (define-vop (symbol-value symbol-global-value) + (:translate symbol-value)) + (define-vop (fast-symbol-value fast-symbol-global-value) + (:translate symbol-value)) + (define-vop (set %set-symbol-global-value))) #!+sb-thread (define-vop (boundp) diff --git a/tests/defglobal.impure.lisp b/tests/defglobal.impure.lisp new file mode 100644 index 0000000..68a74e2 --- /dev/null +++ b/tests/defglobal.impure.lisp @@ -0,0 +1,196 @@ +;;;; DEFGLOBAL and related tests + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(proclaim '(special *foo*)) + +(defun eval* (form) + (let ((*evaluator-mode* :interpret)) + (eval form))) + +(defun unbound-marker () + (sb-c::%primitive sb-c:make-other-immediate-type 0 sb-vm:unbound-marker-widetag)) + +(defun assert-foo-not-checked (fun) + (let* ((marker (unbound-marker)) + (*foo* marker)) + (assert (eq marker (funcall fun))))) + +(defun assert-foo-checked (fun) + (let* ((marker (unbound-marker)) + (*foo* marker)) + (assert (eq :error + (handler-case + (funcall fun) + (unbound-variable (e) + (assert (eq '*foo* (cell-error-name e))) + :error)))))) + +(with-test (:name :unbound-cannot-be-always-bound) + (assert (eq :error + (handler-case + (proclaim '(sb-ext:always-bound *foo*)) + (error () :error))))) + +(set '*foo* t) +(proclaim '(sb-ext:always-bound *foo*)) + +(defun foo-safe () + (declare (optimize (safety 3))) + *foo*) + +(with-test (:name :always-bound-elides-boundness-checking) + (assert-foo-not-checked #'foo-safe)) + +(with-test (:name :cannot-unbind-always-bound) + (assert (eq :oops + (handler-case + (makunbound '*foo*) + (error () :oops))))) + +(defun can-globalize-p (x) + (handler-case + (progn (proclaim `(sb-ext:global ,x)) t) + (error () nil))) + +(with-test (:name :cannot-proclaim-special-global) + (assert (not (can-globalize-p '*foo*)))) + +(define-symbol-macro sm 42) +(with-test (:name :cannot-proclaim-symbol-macro-global) + (assert (not (can-globalize-p 'sm)))) + +(defconstant con 13) +(with-test (:name :cannot-proclaim-constant-global) + (assert (not (can-globalize-p 'con)))) + +(with-test (:name :proclaim-global) + (assert (can-globalize-p '.bar.))) + +(defun bar1 () .bar.) +(with-test (:name :global-does-not-imply-always-bound) + (assert (eq '.bar. + (handler-case + (bar1) + (unbound-variable (e) + (cell-error-name e)))))) + +(with-test (:name :set-global) + (setf .bar. 7) + (assert (= 7 (bar1))) + (setf .bar. 123) + (assert (= 123 (bar1)))) + +(with-test (:name :cannot-bind-globals) + (assert (eq :nope + (handler-case + (eval* '(let ((.bar. 6)) .bar.)) + (error () :nope)))) + (assert (eq :nope + (handler-case + (funcall (compile nil `(lambda () + (let ((.bar. 5)) .bar.)))) + (error () :nope))))) + +(with-test (:name :cannot-define-globals-as-symmacs) + (assert (eq :nope + (handler-case + (eval* '(define-symbol-macro .bar. 0)) + (error () :nope)))) + (assert (eq :nope + (handler-case + (eval* `(symbol-macrolet ((.bar. 11)) .bar.)) + (error () :nope)))) + (assert (eq :nope + (handler-case + (funcall (compile nil `(lambda () + (symbol-macrolet ((.bar. 11)) .bar.)))) + (error () :nope))))) + +;;; Cannot proclaim or declare a global as special +(with-test (:name :cannot-declare-global-special) + (assert (eq :nope + (handler-case (proclaim '(special .bar. 666)) + (error () :nope)))) + (assert (eq :nope + (handler-case + (funcall (compile nil `(lambda () + (declare (special .bar.)) + .bar.))) + (error () :nope)))) + (assert (eq :nope + (handler-case (eval `(locally (declare (special .bar.)) .bar.)) + (error () :nope))))) + +;;; Dead globals get bound checks +(declaim (global this-is-unbound)) +(with-test (:name :dead-unbound-global) + (assert (eq :error + (handler-case + (funcall (compile nil + '(lambda () + this-is-unbound + 42))) + (unbound-variable () + :error))))) + +(defun compile-form (form) + (let* ((lisp "defglobal-impure-tmp.lisp")) + (unwind-protect + (progn + (with-open-file (f lisp :direction :output) + (prin1 form f)) + (multiple-value-bind (fasl warn fail) (compile-file lisp) + (declare (ignore warn)) + (when fail + (error "compiling ~S failed" form)) + fasl)) + (ignore-errors (delete-file lisp))))) + +(defvar *counter*) +(with-test (:name :defconstant-evals) + (let* ((*counter* 0) + (fasl (compile-form `(defglobal .counter-1. (incf *counter*))))) + (assert (= 1 *counter*)) + (assert (= 1 (symbol-value '.counter-1.))) + (assert (eq :global (sb-int:info :variable :kind '.counter-1.))) + (unwind-protect + (load fasl) + (ignore-errors (delete-file fasl))) + (assert (= 1 *counter*)) + (assert (= 1 (symbol-value '.counter-1.)))) + + (set '.counter-2. :bound) + (let* ((*counter* 0) + (fasl (compile-form `(defglobal .counter-2. (incf *counter*))))) + (assert (= 0 *counter*)) + (assert (eq :bound (symbol-value '.counter-2.))) + (assert (eq :global (sb-int:info :variable :kind '.counter-2.))) + (unwind-protect + (load fasl) + (ignore-errors (delete-file fasl))) + (assert (= 0 *counter*)) + (assert (eq :bound (symbol-value '.counter-2.)))) + + ;; This is a *really* dirty trick... + (let* ((*counter* 0) + (fasl (let ((.counter-3. :nasty)) + (declare (special .counter-3.)) + (compile-form `(defglobal .counter-3. (incf *counter*)))))) + (assert (= 0 *counter*)) + (assert (not (boundp '.counter-3.))) + (assert (eq :global (sb-int:info :variable :kind '.counter-3.))) + (unwind-protect + (load fasl) + (ignore-errors (delete-file fasl))) + (assert (= 1 *counter*)) + (assert (= 1 (symbol-value '.counter-3.))))) diff --git a/tests/macroexpand.impure.lisp b/tests/macroexpand.impure.lisp index 8a13935..a59a331 100644 --- a/tests/macroexpand.impure.lisp +++ b/tests/macroexpand.impure.lisp @@ -13,13 +13,13 @@ ;;; From Matthew Swank on cll 2005-10-06 -(defmacro defglobal (name &optional value) +(defmacro defglobal* (name &optional value) (let ((internal (gensym))) `(progn (defparameter ,internal ,value) (define-symbol-macro ,name ,internal)))) -(defglobal glob) +(defglobal* glob) (assert (= (let ((glob 4)) glob))) (assert (null glob)) diff --git a/version.lisp-expr b/version.lisp-expr index 93bfa6f..4876374 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.28.29" +"1.0.28.30" -- 1.7.10.4