mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-21 12:03:40 -08:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'defstruct-redefinition' into 'develop'

Browse source 
defstruct redefinition

Closes #457

See merge request embeddable-common-lisp/ecl!134
This commit is contained in:
Marius Gerbershagen 2019-02-08 20:27:55 +00:00
commit 4902b9dee0
13 changed files with 237 additions and 71 deletions
Download patch file Download diff file Expand all files Collapse all files

8
contrib/package-locks/package-locks.lisp
View file

@ -26,14 +26,6 @@
:one-liner t)
T)
(defun package-locked-p (package &aux (package (si:coerce-to-package package)))
"Returns T when PACKAGE is locked, NIL otherwise. Signals an error
if PACKAGE doesn't designate a valid package."
(ffi:c-inline (package) (:object) :object
"(#0)->pack.locked ? ECL_T : ECL_NIL"
:side-effects nil
:one-liner t))
(defmacro without-package-locks (&body body)
"Ignores all runtime package lock violations during the execution of
body. Body can begin with declarations."

9
src/c/package.d
View file

@ -563,7 +563,7 @@ void
cl_export2(cl_object s, cl_object p)
{
int intern_flag, error;
cl_object other_p, name = ecl_symbol_name(s);
cl_object other_p = ECL_NIL, name = ecl_symbol_name(s);
p = si_coerce_to_package(p);
if (p->pack.locked
&& ECL_SYM_VAL(ecl_process_env(),
@ -966,6 +966,13 @@ si_package_lock(cl_object p, cl_object t)
@(return (previous? ECL_T : ECL_NIL));
}
cl_object
si_package_locked_p (cl_object p)
{
p = si_coerce_to_package(p);
@return (p->pack.locked ? ECL_T : ECL_NIL);
}
/* --- local nicknames ---------------------------------------------------- */
cl_object
si_package_local_nicknames(cl_object p)

3
src/c/symbols_list.h
View file

@ -1207,9 +1207,9 @@ cl_symbols[] = {
/* package extensions */
{SYS_ "*IGNORE-PACKAGE-LOCKS*", SI_SPECIAL, NULL, -1, ECL_NIL},
{EXT_ "PACKAGE-LOCK", EXT_ORDINARY, si_package_lock, 2, OBJNULL},
{EXT_ "PACKAGE-LOCKED-P", EXT_ORDINARY, si_package_locked_p, 1, OBJNULL},
{SYS_ "LOCK-PACKAGE", EXT_ORDINARY, NULL, 1, OBJNULL},
{SYS_ "UNLOCK-PACKAGE", EXT_ORDINARY, NULL, 1, OBJNULL},
{SYS_ "PACKAGE-LOCKED-P", EXT_ORDINARY, NULL, 1, OBJNULL},
{SYS_ "WITHOUT-PACKAGE-LOCKS", EXT_ORDINARY, NULL, 1, OBJNULL},
{SYS_ "WITH-UNLOCKED-PACKAGES", EXT_ORDINARY, NULL, 1, OBJNULL},
{EXT_ "PACKAGE-LOCAL-NICKNAMES", EXT_ORDINARY, si_package_local_nicknames, 1, OBJNULL},
@ -1637,6 +1637,7 @@ cl_symbols[] = {
{MP_ "ATOMIC-INCF-INSTANCE", MP_ORDINARY, IF_MP(mp_atomic_incf_instance), 3, OBJNULL},
{MP_ "DEFINE-CAS-EXPANDER", MP_CONSTANT, NULL, -1, OBJNULL},
{MP_ "DEFCAS", MP_CONSTANT, NULL, -1, OBJNULL},
{MP_ "REMCAS", MP_CONSTANT, NULL, -1, OBJNULL},
{MP_ "GET-CAS-EXPANSION", MP_CONSTANT, NULL, -1, OBJNULL},
{MP_ "COMPARE-AND-SWAP", MP_CONSTANT, NULL, -1, OBJNULL},
{MP_ "ATOMIC-UPDATE", MP_CONSTANT, NULL, -1, OBJNULL},

3
src/c/symbols_list2.h
View file

@ -1207,9 +1207,9 @@ cl_symbols[] = {
/* package extensions */
{SYS_ "*IGNORE-PACKAGE-LOCKS*",NULL},
{EXT_ "PACKAGE-LOCK","si_package_lock"},
{EXT_ "PACKAGE-LOCKED-P","si_package_locked_p"},
{SYS_ "LOCK-PACKAGE",NULL},
{SYS_ "UNLOCK-PACKAGE",NULL},
{SYS_ "PACKAGE-LOCKED-P",NULL},
{SYS_ "WITHOUT-PACKAGE-LOCKS",NULL},
{SYS_ "WITH-UNLOCKED-PACKAGES",NULL},
{EXT_ "PACKAGE-LOCAL-NICKNAMES","si_package_local_nicknames"},
@ -1637,6 +1637,7 @@ cl_symbols[] = {
{MP_ "ATOMIC-INCF-INSTANCE",IF_MP("mp_atomic_incf_instance")},
{MP_ "DEFINE-CAS-EXPANDER",NULL},
{MP_ "DEFCAS",NULL},
{MP_ "REMCAS",NULL},
{MP_ "GET-CAS-EXPANSION",NULL},
{MP_ "COMPARE-AND-SWAP",NULL},
{MP_ "ATOMIC-UPDATE",NULL},

2
src/cmp/proclamations.lsp
View file

@ -453,6 +453,7 @@
(proclamation si:package-hash-tables (package-designator)
(values hash-table hash-table list) :reader)
(proclamation ext:package-lock (package-designator gen-bool) package)
(proclamation ext:package-locked-p (package-designator) boolean :no-side-effects)
(proclamation ext:package-local-nicknames
(package-designator) list :no-side-effects)
(proclamation ext:package-locally-nicknamed-by-list
@ -777,6 +778,7 @@
#+threads (proclamation mp:atomic-incf-car (cons fixnum) fixnum)
#+threads (proclamation mp:compare-and-swap-cdr (cons t t) t)
#+threads (proclamation mp:atomic-incf-cdr (cons fixnum) fixnum)
#+threads (proclamation mp:remcas (symbol) boolean)
;;;
;;; 15. ARRAYS

8
src/doc/help.lsp
View file

@ -2295,6 +2295,14 @@ built-in packages:
system system internal symbols. Has nicknames SYS and SI.
compiler system internal symbols for the ECL compiler.")
(docfun ext:package-lock function
(package-designator lock) "
Sets package's lock to LOCK. Returns previous lock value.")
(docfun ext:package-locked-p function
(package-designator) "
Returns T when PACKAGE is locked, NIL otherwise.")
(docfun ext:package-local-nicknames function
(package-designator) "
Returns an alist of (LOCAL-NICKNAME . ACTUAL-PACKAGE)

7
src/doc/manual/extensions/mp_ref_atomic.txi
View file

@ -227,6 +227,13 @@ Note that it is up to the user of this macro to ensure atomicity for
the resulting compare-and-swap expansions.
@end defmac
@lspindex mp:remcas
@defun mp:remcas symbol
Remove a compare-and-swap expansion. It is an equivalent of
@code{fmakeunbound (setf symbol)} for cas expansions.
@end defun
@lspindex mp:get-cas-expansion
@defun mp:get-cas-expansion place &optional environment

15
src/doc/manual/standards/structures.txi
View file

@ -1,6 +1,21 @@
@node Structures
@section Structures
@subsection Redefining a defstruct structure
@ansi{} says that consequences of redefining a @code{defstruct} are
undefined. @ecl{} defines this behavior to siganal an error if the new
structure is not compatible. Structures are incompatible when:
@table @asis
@item They have a different number of slots
This is particularily important for other structures which could have
included the current one and for already defined instances.
@item Slot name, type or offset is different
Binary compatibility between old and new instances.
@end table
@subsection C Reference
@subsubsection ANSI Dictionary

1
src/h/external.h
View file

@ -1313,6 +1313,7 @@ extern ECL_API cl_object si_remove_package_local_nickname(cl_object n, cl_object
extern ECL_API cl_object cl_list_all_packages(void);
extern ECL_API cl_object si_package_hash_tables(cl_object p);
extern ECL_API cl_object si_package_lock(cl_object p, cl_object t);
extern ECL_API cl_object si_package_locked_p(cl_object p);
extern ECL_API cl_object cl_delete_package(cl_object p);
extern ECL_API cl_object cl_make_package _ECL_ARGS((cl_narg narg, cl_object pack_name, ...));
extern ECL_API cl_object cl_intern _ECL_ARGS((cl_narg narg, cl_object strng, ...));

146
src/lsp/defstruct.lsp
View file

@ -22,21 +22,24 @@
slot-name))
#+threads
(defun make-atomic-accessors (name conc-name type slot-descriptions)
(defun make-atomic-accessors (name conc-name type slot-descriptions removep)
;; If the structure is implemented as a CLOS instance, we can define
;; atomic compare-and-swap expansions for its slots
(when (null type)
(let (accessors)
(dolist (slotd slot-descriptions accessors)
(unless (nth 3 slotd) ; don't create a CAS expansion if the slot is read-only
(let ((access-function (slot-access-function conc-name (nth 0 slotd)))
(offset (nth 4 slotd)))
(push `(mp::define-cas-expander ,access-function (x)
(let ((old (gensym)) (new (gensym)))
(values nil nil old new
`(mp:compare-and-swap-structure ,x ',',name ,',offset ,old ,new)
`(sys:structure-ref ,x ',',name ,',offset))))
accessors)))))))
(let ((access-function (slot-access-function conc-name (nth 0 slotd)))
(read-only (nth 3 slotd))
(offset (nth 4 slotd)))
(if (and (null read-only) (null removep))
(push `(mp::define-cas-expander ,access-function (x)
(let ((old (gensym)) (new (gensym)))
(values nil nil old new
`(mp:compare-and-swap-structure ,x ',',name ,',offset ,old ,new)
`(sys:structure-ref ,x ',',name ,',offset))))
accessors)
;; Don't create a CAS expansion if the slot is read-only.
(push `(mp::remcas ',access-function) accessors)))))))
(defun si::structure-type-error (value slot-type struct-name slot-name)
(error 'simple-type-error
@ -200,7 +203,7 @@
(sys:make-structure .structure-constructor-class. ,@slot-names)))
((subtypep type '(VECTOR T))
`(defun ,constructor-name ,keys
(vector ,@slot-names)))
(vector ,@slot-names)))
((subtypep type 'VECTOR)
`(defun ,constructor-name ,keys
(make-array ',(list (length slot-names))
@ -248,30 +251,23 @@
(defun parse-slot-description (slot-description offset &optional read-only)
(declare (si::c-local))
(let* ((slot-type 'T)
slot-name default-init)
(cond ((atom slot-description)
(setq slot-name slot-description))
((endp (cdr slot-description))
(setq slot-name (car slot-description)))
(t
(setq slot-name (car slot-description))
(setq default-init (cadr slot-description))
(do ((os (cddr slot-description) (cddr os)) (o) (v))
((endp os))
(setq o (car os))
(when (endp (cdr os))
(error "~S is an illegal structure slot option."
os))
(setq v (cadr os))
(case o
(:TYPE (setq slot-type v))
(:READ-ONLY (setq read-only v))
(t
(error "~S is an illegal structure slot option."
os))))))
(list slot-name default-init slot-type read-only offset nil)))
(when (atom slot-description)
(return-from parse-slot-description
(list slot-description nil t read-only offset nil)))
(do ((slot-type T)
(slot-name (first slot-description))
(default-init (second slot-description))
(os (cddr slot-description) (cddr os)))
((endp os)
(list slot-name default-init slot-type read-only offset nil))
(when (endp (cdr os))
(error "~S is an illegal structure slot option." os))
(let ((option (first os))
(value (second os)))
(case option
(:TYPE (setq slot-type value))
(:READ-ONLY (setq read-only value))
(t (error "~S is an illegal structure slot option." os))))))
;;; OVERWRITE-SLOT-DESCRIPTIONS overwrites the old slot-descriptions
;;; with the new descriptions which are specified in the
@ -302,9 +298,38 @@
(sixth new-slot) (sixth old-slot))))
(push new-slot output))))
(defun %struct-layout-compatible-p (old-slot-descriptions new-slot-descriptions)
(declare (si::c-local))
(do* ((old-defs old-slot-descriptions (cdr old-defs))
(new-defs new-slot-descriptions (cdr new-defs)))
((or (null old-defs) (null new-defs))
;; Structures must have the same number of compatible slots.
(and (null old-defs)
(null new-defs)))
(let ((old-def (car old-defs))
(new-def (car new-defs)))
;; We need equal first because slot-description may be a list with
;; (slot-name init …), a list (typed-structure-name ,name) or NIL.
(or (equal old-def new-def)
(destructuring-bind (old-slot-name old-init old-type old-read-only old-offset old-ac)
old-def
(declare (ignore old-init read-only old-ac))
(destructuring-bind (new-slot-name new-init new-type new-read-only new-offset new-ac)
new-def
(declare (ignore new-init new-read-only new-ac))
(and (eql old-slot-name new-slot-name)
(= old-offset new-offset)
(and (subtypep old-type new-type)
(subtypep new-type old-type)))))
(return-from %struct-layout-compatible-p nil)))))
(defun define-structure (name conc-name type named slots slot-descriptions
copier include print-function print-object constructors
offset name-offset documentation predicate)
(let ((old-slot-descriptions (get-sysprop name 'structure-slot-descriptions)))
(when (and old-slot-descriptions
(null (%struct-layout-compatible-p old-slot-descriptions slot-descriptions)))
(error "Attempt to redefine the structure ~S incompatibly with the current definition." name)))
(create-type-name name)
;; We are going to modify this list!!!
(setf slot-descriptions (copy-tree slot-descriptions))
@ -420,7 +445,7 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)."
(:INCLUDE
(setq include (cdar os))
(unless (get-sysprop v 'IS-A-STRUCTURE)
(error "~S is an illegal included structure." v)))
(error "~S is an illegal included structure." v)))
(:PRINT-FUNCTION (setq print-function v))
(:PRINT-OBJECT (setq print-object v))
(:TYPE (setq type v))
@ -444,14 +469,13 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)."
;; Skip the documentation string.
(when (and (not (endp slot-descriptions))
(stringp (car slot-descriptions)))
(setq documentation (car slot-descriptions))
(setq slot-descriptions (cdr slot-descriptions)))
(setq documentation (car slot-descriptions))
(setq slot-descriptions (cdr slot-descriptions)))
;; Check the include option.
(when include
(unless (equal type (get-sysprop (car include) 'STRUCTURE-TYPE))
(error "~S is an illegal structure include."
(car include))))
(when (and include
(not (equal type (get-sysprop (car include) 'STRUCTURE-TYPE))))
(error "~S is an illegal structure include." (car include)))
;; Set OFFSET.
(setq offset (if include
@ -460,13 +484,13 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)."
;; Increment OFFSET.
(when (and type initial-offset)
(setq offset (+ offset initial-offset)))
(setq offset (+ offset initial-offset)))
(when (and type named)
(unless (or (subtypep '(vector symbol) type)
(subtypep type 'list))
(error "Structure cannot have type ~S and be :NAMED." type))
(setq name-offset offset)
(setq offset (1+ offset)))
(unless (or (subtypep '(vector symbol) type)
(subtypep type 'list))
(error "Structure cannot have type ~S and be :NAMED." type))
(setq name-offset offset)
(setq offset (1+ offset)))
;; Parse slot-descriptions, incrementing OFFSET for each one.
(do ((ds slot-descriptions (cdr ds))
@ -479,13 +503,13 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)."
;; If TYPE is non-NIL and structure is named,
;; add the slot for the structure-name to the slot-descriptions.
(when (and type named)
(setq slot-descriptions
(cons (list 'TYPED-STRUCTURE-NAME name) slot-descriptions)))
(setq slot-descriptions
(cons (list 'TYPED-STRUCTURE-NAME name) slot-descriptions)))
;; Pad the slot-descriptions with the initial-offset number of NILs.
(when (and type initial-offset)
(setq slot-descriptions
(append (make-list initial-offset) slot-descriptions)))
(setq slot-descriptions
(append (make-list initial-offset) slot-descriptions)))
;; Append the slot-descriptions of the included structure.
;; The slot-descriptions in the include option are also counted.
@ -507,7 +531,7 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)."
;; If a constructor option is NIL,
;; no constructor should have been specified.
(when constructors
(error "Contradictory constructor options.")))
(error "Contradictory constructor options.")))
((null constructors)
;; If no constructor is specified,
;; the default-constructor is made.
@ -533,10 +557,10 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)."
;; LOAD-TIME-VALUE.
;;
(let ((core `(define-structure ',name ',conc-name ',type ',named ',slots
',slot-descriptions ',copier ',include
',print-function ',print-object ',constructors
',offset ',name-offset
',documentation ',predicate))
',slot-descriptions ',copier ',include
',print-function ',print-object ',constructors
',offset ',name-offset
',documentation ',predicate))
(constructors (mapcar #'(lambda (constructor)
(make-constructor name constructor type named
slot-descriptions))
@ -551,7 +575,9 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)."
(eval-when (:execute)
(let ((.structure-constructor-class. ,core))
,@constructors))
,(when atomic-accessors
`(eval-when (:compile-toplevel :load-toplevel :execute)
#+threads ,@(make-atomic-accessors name conc-name type slot-descriptions)))
#+threads
(eval-when (:compile-toplevel :load-toplevel :execute)
;; When ATOMIC-ACCESSORS is NIL then MP:REMCAS is collected instead.
,@(make-atomic-accessors name conc-name type slot-descriptions (not atomic-accessors)))
',name))))

24
src/lsp/mp.lsp
View file

@ -204,6 +204,15 @@ the resulting COMPARE-AND-SWAP expansions."
(setq lambda-list (cons env lambda-list))
(push `(declare (ignore ,env)) body))))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(let ((package (symbol-package ',accessor)))
(when (and package
(ext:package-locked-p package)
(null si:*ignore-package-locks*))
(si:signal-simple-error 'package-error
"Ignore lock and proceed."
"Attempt to define CAS accessor ~S in locked package."
'(,accessor)
:package package)))
(si:put-sysprop ',accessor 'CAS-EXPANDER #'(ext::lambda-block ,accessor ,lambda-list ,@body))
',accessor))
@ -223,6 +232,21 @@ the resulting COMPARE-AND-SWAP expansions."
`(,',cas-fun ,@args ,old ,new)
`(,',accessor ,@args)))))
#+threads
(defun remcas (symbol)
"Remove a COMPARE-AND-SWAP expansion. It is a CAS operation equivalent of
(FMAKUNBOUND (SETF SYMBOL))"
(let ((package (symbol-package symbol)))
(when (and package
(ext:package-locked-p package)
(null si:*ignore-package-locks*))
(si:signal-simple-error 'package-error
"Ignore lock and proceed."
"Attempt to define CAS accessor ~S in locked package."
(list symbol)
:package package)))
(si:rem-sysprop symbol 'cas-expander))
#+threads
(defun get-cas-expansion (place &optional environment &aux f)
"Returns the COMPARE-AND-SWAP expansion forms and variables as defined

51
src/tests/normal-tests/ansi.lsp
View file

@ -45,6 +45,57 @@
(is-true (typep '* '(nest (3) 3)))
(is-true (typep 3 '(nest (2) 3)))))
;;; 8. Structures
(ext:with-clean-symbols
(my-struct make-my-struct my-struct-2 make-my-struct-2 my-struct-compatible-type)
(test ansi.8.redefine-compatible
(let (foo-1 foo-2 foo-3 foo-4)
(defstruct (my-struct (:constructor make-my-struct)) slot-1 slot-2)
(setq foo-1 (make-my-struct :slot-1 3 :slot-2 4))
(finishes (defstruct (my-struct (:constructor make-my-struct))
(slot-1 nil)
(slot-2 t)))
(setq foo-2 (make-my-struct :slot-1 3 :slot-2 4))
(finishes (defstruct (my-struct (:constructor make-my-struct))
(slot-1 3)
(slot-2 4)))
(setq foo-3 (make-my-struct))
(finishes (defstruct (my-struct (:constructor make-my-struct))
(slot-1 8 :type t :read-only nil)
(slot-2 8 :type t :read-only nil)))
(setq foo-4 (make-my-struct :slot-1 3 :slot-2 4))
(is (equalp foo-1 foo-2))
(is (equalp foo-2 foo-3))
(is (equalp foo-3 foo-4)))
(deftype my-struct-compatible-type () `(integer 0 10))
(defstruct (my-struct-2 (:constructor make-my-struct-2))
(slot-1 nil :type my-struct-compatible-type :read-only t))
(finishes
(defstruct my-struct-2
(slot-1 nil :type (integer 0 10) :read-only t)))
(finishes
(defstruct my-struct-2
(slot-1 4 :type (integer 0 10) :read-only t)))
(finishes
(defstruct my-struct-2
(slot-1 4 :type (integer 0 10) :read-only nil)))))
(ext:with-clean-symbols (my-struct make-my-struct)
(test ansi.8.redefine-incompatible
(defstruct (my-struct (:constructor make-my-struct)) slot-1 slot-2)
;; different slot type
(signals error (defstruct (my-struct (:constructor make-my-struct))
(slot-1 nil :type integer)
(slot-2 t)))
;; too many slots
(signals error (defstruct (my-struct (:constructor make-my-struct)) slot-1 slot-2 slot-3))
;; too few slots
(signals error (defstruct (my-struct (:constructor make-my-struct)) slot-1))
;; incompatible names
(signals error (defstruct (my-struct (:constructor make-my-struct)) slot-1x slot-2x))
(finishes (make-my-struct))))
;;;;;;;;;;;;;;;;;;;;;;;;;;

31
src/tests/normal-tests/multiprocessing.lsp
View file

@ -704,3 +704,34 @@ creating stray processes."
(is (svref vector 1) 0)
(is *x* 0)
(is (slot-value object 'slot1) 0)))))
;;; Date: 2019-02-05
;;; From: Daniel Kochmański
;;; Description:
;;;
;;; Verifies that CAS expansion may be removed.
;;;
(ext:with-clean-symbols (*obj* foo)
(test defcas/remcas
(mp:defcas foo (lambda (object old new)
(assert (consp object))
(setf (car object) old
(cdr object) new)))
(defparameter *obj* (cons nil nil))
(eval `(mp:compare-and-swap (foo *obj*) :car :cdr))
(is (eql (car *obj*) :car))
(is (eql (cdr *obj*) :cdr))
(mp:remcas 'foo)
(signals error (eval `(mp:compare-and-swap (foo *obj*) :car :cdr)))))
;;; Date: 2019-02-07
;;; From: Daniel Kochmański
;;; Description:
;;;
;;; Verifies that CAS modifications honor the package locks.
;;;
(test cas-locked-package
(signals package-error (mp:defcas cl:car (lambda (obj old new) nil)))
(signals package-error (mp:remcas 'cl:car))
(finishes (mp:defcas cor (lambda (obj old new) nil)))
(finishes (mp:remcas 'cor)))