Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

This patch makes defstructs able to be redefined. #498

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open

This patch makes defstructs able to be redefined. #498

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
This patch makes defstructs able to be redefined. Currently, ABCL 
catches the case where the defstruct has been changed and throws an
error. The main issue with defstruct is that when compiling, the
accessors are inlined as position-based accessors. So

(defstruct a b)

will compile a-b into lispObject.getSlotValue_0().

If another slot is added at the beginning
(defstruct a first b)

Then using a-b will get the value of the slot first instead of b.

The mechanism that ABCL uses to do inline is a source
transform. Allowing redefinition prevents that source transformation
from being created. Without the source transform, the compiled accessors
get the correct slot, at the cost of some performance.

Redefinition is controlled by a global variable
*allow-defstruct-redefinition* and a new option to defstruct :optimize.
If *allow-defstruct-redefinition* is t then

(defstruct (a :optimize nil) b)

Will prevent the source transform from being created. Otherwise the
current ABCL behavior is replicated.

The way ABCL detects that a change has been made is by saving the slot
definitions in the structure class, in a map of class names to
class-object defined in LispClass. The class object has a copy of the
slot definitions. One change is that we make is to make that map public.
There's an accessor findClass, but the result can't be cast to a
StructureClass, which the it needs to be in order to do the redefinition.

Then we add a new java function in StructureClass.java
reinitialize-structure-class, which replicates most of the logic of
make-structure-class, except that it reuses the old structure class
object. It's necessary to use the old value so that generic methods
specialized on the class will still work.

In defstruct.lisp there are changes to recognize the new option, to
check it before defining source transforms, and to call reinitialize-structure-class
instead of make-structure-class if the defstruct is already defined.

In the case that a defstruct is first created without the :optimize
option then subseqently modified to use :optimize nil, a warning is
given that previously compiled functions that use the accessors may need
to be recompiled and the previously defined source transforms are removed.
However, as long as the order of previously defined slots in the newly
defined defstruct remains the same as the order in the old structure,
inlined accessors will continue to work and recompilation is not
necessary.

The intended use of redefinition is during development, where structures
may evolve. There's no reason to use this mechanism in production code.
  • Loading branch information
@alanruttenberg
alanruttenberg committed Aug 3, 2022
commit 282af922bb16b368a9f5520639761b09cc8501fd
2 changes: 1 addition & 1 deletion src/org/armedbear/lisp/LispClass.java
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -38,7 +38,7 @@

public abstract class LispClass extends StandardObject
{
private static final ConcurrentHashMap<Symbol, LispObject> map
public static final ConcurrentHashMap<Symbol, LispObject> map
= new ConcurrentHashMap<Symbol, LispObject>();

public static <T extends LispClass> T addClass(Symbol symbol, T c)
Expand Down
29 changes: 29 additions & 0 deletions src/org/armedbear/lisp/StructureClass.java
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -125,4 +125,33 @@ public LispObject execute(LispObject first, LispObject second,
return c;
}
};
// ### reinitialize-structure-class name direct-slots slots include => class
private static final Primitive REINITIALIZE_STRUCTURE_CLASS =
new Primitive("reinitialize-structure-class", PACKAGE_SYS, false)
{
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third, LispObject fourth)

{
Symbol symbol = checkSymbol(first);
LispObject directSlots = checkList(second);
LispObject slots = checkList(third);
Symbol include = checkSymbol(fourth);

StructureClass c = (StructureClass)LispClass.map.get(symbol);
if (include != NIL) {
LispClass includedClass = LispClass.findClass(include);
if (includedClass == null)
return error(new SimpleError("Class " + include +
" is undefined."));
c.setCPL(new Cons(c, includedClass.getCPL()));
} else
c.setCPL(c, BuiltInClass.STRUCTURE_OBJECT, BuiltInClass.CLASS_T);
c.setDirectSlotDefinitions(directSlots);
c.setSlotDefinitions(slots);
c.setFinalized(true);
return c;
}
};
}
144 changes: 84 additions & 60 deletions src/org/armedbear/lisp/defstruct.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -126,7 +126,8 @@
(defvar *dd-slots*)
(defvar *dd-inherited-accessors*)
(defvar *dd-documentation*)

(defvar *dd-optimize* t)

(defun keywordify (symbol)
(intern (symbol-name symbol) +keyword-package+))

Expand Down Expand Up @@ -353,28 +354,30 @@
(type (dsd-type slot)))
(cond ((eq *dd-type* 'list)
`((declaim (ftype (function * ,type) ,accessor-name))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
(setf (symbol-function ',accessor-name)
(make-list-reader ,index))))
((or (eq *dd-type* 'vector)
(and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
`((declaim (ftype (function * ,type) ,accessor-name))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
(setf (symbol-function ',accessor-name)
(make-vector-reader ,index))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
(define-source-transform ,accessor-name (instance)
`(aref (truly-the ,',*dd-type* ,instance) ,,index))))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
,@(when *dd-optimize*
`((define-source-transform ,accessor-name (instance)
`(aref (truly-the ,',*dd-type* ,instance) ,,index))))))
(t
`((declaim (ftype (function * ,type) ,accessor-name))
(setf (symbol-function ',accessor-name)
(make-structure-reader ,index ',*dd-name*))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
(define-source-transform ,accessor-name (instance)
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
,@(when *dd-optimize*
`((define-source-transform ,accessor-name (instance)
,(if (eq type 't)
``(structure-ref (the ,',*dd-name* ,instance) ,,index)
``(the ,',type
(structure-ref (the ,',*dd-name* ,instance) ,,index)))))))))
(structure-ref (the ,',*dd-name* ,instance) ,,index)))))))))))

(defun make-list-writer (index)
#'(lambda (value instance)
Expand All @@ -400,22 +403,24 @@
(index (dsd-index slot)))
(cond ((eq *dd-type* 'list)
`((record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
(setf (get ',accessor-name 'setf-function)
(setf (get ',accessor-name 'setf-function)
(make-list-writer ,index))))
((or (eq *dd-type* 'vector)
(and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
`((setf (get ',accessor-name 'setf-function)
(make-vector-writer ,index))
(record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
(define-source-transform (setf ,accessor-name) (value instance)
`(aset (truly-the ,',*dd-type* ,instance) ,,index ,value))))
(record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
,@(when *dd-optimize*
`((define-source-transform (setf ,accessor-name) (value instance)
`(aset (truly-the ,',*dd-type* ,instance) ,,index ,value))))))
(t
`((setf (get ',accessor-name 'setf-function)
(make-structure-writer ,index ',*dd-name*))
(record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
(define-source-transform (setf ,accessor-name) (value instance)
`(structure-set (the ,',*dd-name* ,instance)
,,index ,value)))))))
(record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
,@(when *dd-optimize*
`((define-source-transform (setf ,accessor-name) (value instance)
`(structure-set (the ,',*dd-name* ,instance)
,,index ,value)))))))))

(defun define-access-functions ()
(let ((result ()))
Expand Down Expand Up @@ -493,7 +498,11 @@
(setf *dd-type* (cadr option))
(when (and (consp *dd-type*) (eq (car *dd-type*) 'vector))
(unless (eq (second *dd-type*) '*)
(setf *dd-default-slot-type* (second *dd-type*)))))))
(setf *dd-default-slot-type* (second *dd-type*)))))
(:optimize
(setf *dd-optimize* (if (null (cadr option)) nil t)))

))

(defun parse-name-and-options (name-and-options)
(setf *dd-name* (the symbol (car name-and-options)))
Expand All @@ -511,40 +520,43 @@
(t
(error "Unrecognized DEFSTRUCT option: ~S." option))))))

(defvar *allow-defstruct-redefinition* nil)

(defun compiler-defstruct (name &key
conc-name
default-constructor
constructors
copier
include
type
named
initial-offset
predicate
print-function
print-object
direct-slots
slots
inherited-accessors
documentation)
conc-name
default-constructor
constructors
copier
include
type
named
initial-offset
predicate
print-function
print-object
direct-slots
slots
inherited-accessors
documentation
optimize)
(let ((description
(make-defstruct-description :name name
:conc-name conc-name
:default-constructor default-constructor
:constructors constructors
:copier copier
:include include
:type type
:named named
:initial-offset initial-offset
:predicate predicate
:print-function print-function
:print-object print-object
:direct-slots direct-slots
:slots slots
:inherited-accessors inherited-accessors))
(make-defstruct-description :name name
:conc-name conc-name
:default-constructor default-constructor
:constructors constructors
:copier copier
:include include
:type type
:named named
:initial-offset initial-offset
:predicate predicate
:print-function print-function
:print-object print-object
:direct-slots direct-slots
:slots slots
:inherited-accessors inherited-accessors))
(old (get name 'structure-definition)))
(when old
(when (and old (not (and *allow-defstruct-redefinition* (not optimize))))
(unless
;; Assert that the structure definitions are exactly the same
;; we need to support this type of redefinition during bootstrap
Expand Down Expand Up @@ -572,15 +584,25 @@
:format-arguments (list name)))
;; Since they're the same, continue with the old one.
(setf description old))
(setf (get name 'structure-definition) description))
(%set-documentation name 'structure documentation)
(when (or (null type) named)
(let ((structure-class
(make-structure-class name direct-slots slots (car include))))
(%set-documentation name 'type documentation)
(%set-documentation structure-class t documentation)))
(when default-constructor
(proclaim `(ftype (function * t) ,default-constructor))))
(setf (get name 'structure-definition) description)
(%set-documentation name 'structure documentation)
(when (or (null type) named (and old *allow-defstruct-redefinition*))
(let ((structure-class
(if (and old *allow-defstruct-redefinition*)
(progn
(block warn
(dolist (slot slots)
(when (get-function-info-value (dsd-reader slot) :source-transform)
(warn "Redefining structure ~a, previously optimized. You should recompile code using accessors"
name)
(return-from warn nil))))
(dolist (slot slots) (set-function-info-value (dsd-reader slot) :source-transform nil))
(reinitialize-structure-class name direct-slots slots (car include)))
(make-structure-class name direct-slots slots (car include)))))
(%set-documentation name 'type documentation)
(%set-documentation structure-class t documentation)))
(when default-constructor
(proclaim `(ftype (function * t) ,default-constructor)))))

(defmacro defstruct (name-and-options &rest slots)
(let ((*dd-name* nil)
Expand All @@ -599,7 +621,8 @@
(*dd-direct-slots* ())
(*dd-slots* ())
(*dd-inherited-accessors* ())
(*dd-documentation* nil))
(*dd-documentation* nil)
(*dd-optimize* t))
(parse-name-and-options (if (atom name-and-options)
(list name-and-options)
name-and-options))
Expand Down Expand Up @@ -704,7 +727,8 @@
:direct-slots ',*dd-direct-slots*
:slots ',*dd-slots*
:inherited-accessors ',*dd-inherited-accessors*
:documentation ',*dd-documentation*))
:documentation ',*dd-documentation*
:optimize ',*dd-optimize*))
(record-source-information-for-type ',*dd-name* :structure)
,@(define-constructors)
,@(define-predicate)
Expand Down