Browse files

pretty printing for mtagmaps and a few cleanups

  • Loading branch information...
1 parent 479fe07 commit 96b771c00e64607a69c272ef0bcb302326bcde6f @ilitirit ilitirit committed Sep 4, 2009
Showing with 61 additions and 31 deletions.
  1. +25 −19 src/box.lisp
  2. +3 −3 src/class.lisp
  3. +15 −0 src/finalize.lisp
  4. +0 −7 src/gc.lisp
  5. +3 −1 src/mop.lisp
  6. +13 −0 src/mtagmap.lisp
  7. +2 −1 src/package.lisp
View
44 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)
View
6 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))
View
15 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)
+
View
7 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)))
View
4 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
View
13 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)))))
+
View
3 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

0 comments on commit 96b771c

Please sign in to comment.