[elephant-devel] postmodern / lispworks issues

[Carlos Ungil]

Hello,

I'd like to propose a few changes to the code available at http://www.common-lisp.net/project/elephant/darcs/elephant-1.0/ (I understand this is "the" repository, at least quicklisp seems to use it).
 
With the following changes, (do-backend-tests) runs without failures using postmodern in each combination of Lispworks/AllegroCL/SBCL and MacOSX/Windows (for some reason there is one check less in Lispworks, 582 instead of 583).

1) There is a bug that is not specific to Lispworks or Postmodern (it's the reason why CACHING-STYLE-REQUIRED fails). In src/elephant/classes.lisp

    79    (when (and (not cache-style) (has-cached-slot-specification direct-slots)
    80               (not (superclass-member-p 'cacheable-persistent-object
    81                                         (class-direct-superclasses class))))
    82      (error "Must specify the class caching style if you declare cached slots and don't~%inherit from a cached class.  Class option :cache-style must be one of~% :checkout, :txn or :none"))

the call to superclass-member-p is wrong, should be (superclass-member-p (find-class 'cacheable-persistent-object) direct-superclasses)

2) In ele-postmodern.asd there is a reference to (:file "pm-pset"), but I don't think the file was ever added to the repository. Removing the reference everything seems to work (of course adding the file would be better).

3) UPDATE-SLOT-INDEX-NIL-VALUE and SLOT-MAKUNBOUND-NIL-VALUE fail because nil values are not indexed. In src/db-postmodern/pm-btree.lisp, line 417

   416  (defmethod (setf internal-get-value) (value key (bt pm-btree))
   417    (when key
   418      (if (initialized-p bt)

the "when key" check should be removed, I think. I don't know if there might be any case where it's required, but at least the test suite runs without issues.

4) A conditional "#-lispworks" is missing in src/elephant/serializer2.lisp, line 455:
   452               ((= tag +utf8-string+)
   453                #+lispworks
   454                (coerce (deserialize-string :utf8 bs) 'base-string)
   455
   456                (deserialize-string :utf8 bs))

5) Replace the #+lispworks defmethods at the end of src/elephant/slots.lisp (lines 209-233) with the following:

#+lispworks
(defmethod slot-value-using-class ((class persistent-metaclass) (instance persistent-object) (slot symbol))
  (let ((slot-def (or (find slot (class-slots class) :key 'slot-definition-name)
 		      (find slot (class-slots class)))))
    (if (typep slot-def (or 'persistent-slot-definition 'cached-slot-definition))
	(slot-value-using-class class instance slot-def)
	(call-next-method))))

#+lispworks
(defmethod (setf slot-value-using-class) (new-value (class persistent-metaclass) (instance persistent-object) (slot symbol))
  (let ((slot-def (or (find slot (class-slots class) :key 'slot-definition-name)
 		      (find slot (class-slots class)))))
    (if (typep slot-def (or 'persistent-slot-definition 'cached-slot-definition))
	(setf (slot-value-using-class class instance slot-def) new-value)
	(call-next-method))))

#+lispworks
(defmethod slot-makunbound-using-class ((class persistent-metaclass) (instance persistent-object) (slot symbol))
  (let ((slot-def (or (find slot (class-slots class) :key 'slot-definition-name)
 		      (find slot (class-slots class)))))
    (if (typep slot-def (or 'persistent-slot-definition 'cached-slot-definition))
	(slot-makunbound-using-class class instance slot-def)
	(call-next-method))))

#+lispworks
(defmethod slot-boundp-using-class ((class persistent-metaclass) (instance persistent-object) (slot symbol))
  (let ((slot-def (or (find slot (class-slots class) :key 'slot-definition-name)
 		      (find slot (class-slots class)))))
    (if (typep slot-def (or 'persistent-slot-definition 'cached-slot-definition))
	(slot-boundp-using-class class instance slot-def)
	(call-next-method))))

6) The remaining modifications add support for cacheable-persistent-objects. This is more a work-around that a proper implementation and it might not by correct (but at least it passes the tests).

Adding the following method to src/elephant/cache.lisp ensures that cached slots are properly initialized in the database by recreating them after the instance has been created (it calls explicitly the slot-value-using-class and slot-makunbound-using-class methods).

#+lispworks 
(defmethod initialize-instance :after ((instance cacheable-persistent-object) &key from-oid (make-cached-instance nil make-cached-instance-p) &allow-other-keys)
  (dolist (slot (cached-slot-defs (class-of instance)))
    (if (slot-boundp instance (slot-definition-name slot))
	(setf (slot-value-using-class (class-of instance) instance slot)
	      (slot-value instance (slot-definition-name slot)))
      (slot-makunbound-using-class (class-of instance) instance slot)))
  instance)

In src/elephant/cached-slots.lisp, a couple of #+lispworks lines can fix the loss of sync for cached slots happening under some circumstances.

    83  (defmethod (setf caching-style) (style (class persistent-metaclass))
    84    (case style
    85      ((or :checkout :txn)
    86       (unless (cached-slot-defs class)
    87         (error "Cannot enable caching for classes with no cached slots"))
    88       (setf (%cache-style class) style))
    89      (:none
               #+lispworks (map-class (lambda (x) (when (checked-out-p x) (persistent-checkout-cancel x))) class)
    90       (setf (%cache-style class) style))
    91      (t (error "Unknown caching mode ~A" style))))

   155  (defmethod persistent-checkout-cancel ((object cacheable-persistent-object))
   156    (ensure-transaction ()
   157      (assert (pchecked-out-p object))
               #+lispworks (refresh-cached-slots object (cached-slot-names (class-of object)))
   158      (setf (pchecked-out-p object) nil)
   159      (setf (checked-out-p object) nil)))

Cheers,

Carlos