pretty printing for mtagmaps and a few cleanups

src/box.lisp

@@ -6,9 +6,9 @@
 	((mpointer tag index) mm-box)
       (mptr-to-lisp-object ptr))))
 
-(defun box-cons (cons)
-  ;;; XXX this is terrible anyway so don't bother making it efficient
-  (%ptr (make-instance 'mm-cons :car (car cons) :cdr (cdr cons))))
+(defun-speedy box-cons (cons)
+  ;;; XXX this is a lost cause anyway so don't bother making it efficient?
+  (ptr (make-instance 'mm-cons :car (car cons) :cdr (cdr cons))))
 
 (with-constant-tag-for-class (tag mm-cons)
   (check-class-slot-layout mm-cons)
@@ -26,27 +26,33 @@
 (with-constant-tag-for-class (tag mm-symbol)
   (check-class-slot-layout mm-symbol)
 
+  (declaim (ftype (function (symbol) (mptr)) uncached-box-symbol box-symbol))
+  (defun uncached-box-symbol (object)
+    (declare (type symbol object)
+	     (optimize speed))
+    (let* 
+	((pkg (symbol-package object)) 
+	 (mptr (ptr 
+		(make-instance 'mm-symbol 
+			       :package 
+			       (if pkg
+				   (package-name pkg)
+				   nil)
+			       :symbol
+			       (symbol-name object)))))
+      (assert (not (zerop mptr)))
+      (when pkg 
+	(push object *stored-symbols*)
+	(setf (prop-for-mm-symbol object) mptr))
+      mptr))
+
   (defun-speedy box-symbol (object)
     (declare (type symbol object))
     (cond ((not object)
 	   (make-mptr tag 0))
 	  (t
-	   (symbol-macrolet ((prop (prop-for-mm-symbol object)))
-	     (or prop
-		 (let* ((pkg (symbol-package object)) 
-		       (mptr (%ptr 
-			      (make-instance 'mm-symbol 
-					     :package 
-					     (if pkg
-						 (package-name pkg)
-						 nil)
-					 :symbol
-					 (symbol-name object)))))
-		   (assert (not (zerop mptr)))
-		   (when pkg 
-		     (push object *stored-symbols*)
-		     (setf prop mptr))
-		   mptr))))))
+	   (or (prop-for-mm-symbol object)
+	       (uncached-box-symbol object)))))
 
  (defun-speedy unbox-symbol (index)
    (unless (zerop index)

src/class.lisp

@@ -3,7 +3,7 @@
 (defmacro define-lisp-object-to-mptr ()
   `(defun-speedy lisp-object-to-mptr (obj)
        (typecase obj
-	 (mm-object (%ptr obj))
+	 (mm-object (ptr obj))
 	 (t (box-object obj)))))
 
 (define-lisp-object-to-mptr) ;; should be redefined after box-object is
@@ -28,7 +28,7 @@
 (defun-speedy force-mptr (obj)
   (etypecase obj
     (mptr obj)
-    (mm-object (%ptr obj))))
+    (mm-object (ptr obj))))
 
 (defun-speedy mptr (obj)
   (force-mptr obj))
@@ -39,7 +39,7 @@
     (mtagmap (mm-metaclass-tag (mtagmap-class obj)))
     (symbol (mm-metaclass-tag (find-class obj)))
     (mm-metaclass (mm-metaclass-tag obj))
-    (mm-object (mptr-tag (%ptr obj)))
+    (mm-object (mptr-tag (ptr obj)))
     (mptr (mptr-tag obj))))
 
 (defmethod finalize-inheritance :after ((class mm-metaclass))

src/finalize.lisp

@@ -43,5 +43,20 @@
 	(when (and m (not (mtagmap-closed-p m)))
 	  (mtagmap-shrink m))))
 
+
+(defun wipe-all-mmaps ()
+  (clear-caches)
+  (loop for m across *mtagmaps*
+	when (and m (not (mtagmap-closed-p m)))
+	do
+	(setf (mtagmap-next m) (mtagmap-first-index m))
+	(mtagmap-shrink m)))
+
+(defun print-all-mmaps (&optional (stream *standard-output*))
+  (loop for m across *mtagmaps*
+	when (and m (not (mtagmap-closed-p m)))
+	do (format stream "~&~A~%" m)))
+
 (define-lisp-object-to-mptr)
 
+

src/gc.lisp

@@ -128,10 +128,3 @@ does not need so much memory.
 	    (shrink-all-mmaps))
 	  (values)))))
 
-(defun wipe-all ()
-  (clear-caches)
-  (loop for m across *mtagmaps*
-	when (and m (not (mtagmap-closed-p m)))
-	do
-	(setf (mtagmap-next m) (mtagmap-first-index m))
-	(mtagmap-shrink m)))

src/mop.lisp

@@ -18,9 +18,11 @@
 (defun-speedy ptr (object)
   (declare (type mm-object object))
   (the mptr (%ptr object)))
+(define-compiler-macro ptr (object)
+  `(the mptr (%ptr (the mm-object ,object))))
 
 (defun-speedy mm-object-pointer (mm-object)
-  (mptr-pointer (the mptr (ptr mm-object))))
+  (mptr-pointer (ptr mm-object)))
 
 (defmethod shared-initialize :around ((class mm-metaclass)
 				      slot-names

src/mtagmap.lisp

@@ -246,3 +246,16 @@
 (defun mtagmap-schema (mtagmap)
   (let ((class (mtagmap-class mtagmap)))
     (mm-metaclass-schema class)))
+
+
+(defmethod print-object ((m mtagmap) stream)
+  (print-unreadable-object (m stream :type t)
+    (unless (mtagmap-closed-p m)
+      (format stream "~A (~D): ~D objects, ~D bytes, ~D bytes mapped (~A)"
+	      (class-name (mtagmap-class m))
+	      (force-tag m)
+	      (mtagmap-count m)
+	      (mtagmap-next m)
+	      (mtagmap-len m)
+	      (mtagmap-default-filename m)))))
+

src/package.lisp

@@ -8,6 +8,8 @@
    #:*mmap-may-allocate*
    #:close-all-mmaps
    #:open-all-mmaps
+   #:wipe-all-mmaps
+   #:print-all-mmaps
    #:doclass
    #:dosubclasses
    #:retrieve-all-instances
@@ -26,7 +28,6 @@
 
    #:gc
    #:rewrite-gc
-   #:wipe-all
 
    #:make-mm-fixed-string
    #:mm-fixed-string-value