[steeldump-cvs] r20 - trunk/sb-heapdump

[dlichteblau at common-lisp.net]

Author: dlichteblau
Date: Sat Aug 25 17:10:48 2007
New Revision: 20

Modified:
   trunk/sb-heapdump/dump.lisp
   trunk/sb-heapdump/relocate.c
Log:
update to SBCL 1.0.8.46


Modified: trunk/sb-heapdump/dump.lisp
==============================================================================
--- trunk/sb-heapdump/dump.lisp	(original)
+++ trunk/sb-heapdump/dump.lisp	Sat Aug 25 17:10:48 2007
@@ -58,6 +58,9 @@
   (worklist (error "oops"))
   (worklist-tail (error "oops")))
 
+(defmethod print-object ((object ctx) stream)
+  (print-unreadable-object (object stream)))
+
 (defvar *disable-customizer* nil)
 (defconstant +invalid+ 0)
 
@@ -77,6 +80,7 @@
   (with-open-file (s pathname
                    :direction :output
                    :element-type '(unsigned-byte 8)
+                   :if-does-not-exist :create
                    ;; Argh!  SBCL implements :append as O_APPEND, even though
                    ;; the Hyperspec says to position the file pointer at
                    ;; the end of the file *initially*.
@@ -497,12 +501,14 @@
       (dump-unboxed object ctx pos))
     ((or symbol ratio complex)
       (dump-boxed object ctx pos))
+    (sb-kernel:funcallable-instance
+      (dump-funcallable-instance object ctx pos))
     (simple-vector (dump-simple-vector object ctx pos))
     ((simple-array * (*)) (dump-primitive-vector object ctx pos))
     (array (dump-boxed object ctx pos))
     (sb-kernel:instance (dump-instance object ctx pos))
     (sb-kernel:code-component (dump-code-component object ctx pos))
-    (function (dump-non-simple-fun object ctx pos))
+    (function (dump-closure object ctx pos))
     (sb-kernel:fdefn (dump-fdefn object ctx pos))
     (sb-ext:weak-pointer
       (multiple-value-bind (value alive)
@@ -543,6 +549,20 @@
         (dolist (slot slots)
           (write-word slot ctx))))))
 
+(defun dump-funcallable-instance (object ctx pos)
+  (let ((len (sb-kernel:get-closure-length object)))
+    (incf (ctx-position ctx) (* (1+ len) +n+))
+    (lambda ()
+      (let ((slots
+             (loop
+                for i from 1 to len
+                collect
+                  (sub-dump-object (object-ref-lispobj object i) ctx))))
+        (seek ctx pos)
+        (write-word (make-header-word len (sb-kernel:widetag-of object)) ctx)
+        (dolist (slot slots)
+          (write-word slot ctx))))))
+
 (defun dump-unboxed (object ctx pos)
   (let ((len (sb-kernel:get-header-data object)))
     (incf (ctx-position ctx) (* (1+ len) +n+))
@@ -590,6 +610,8 @@
     nil))
 
 (defun dump-instance (instance ctx pos)
+  (when (typep instance 'hash-table)
+    (assert (not (sb-impl::hash-table-weakness instance))))
   (let* ((len (sb-kernel:%instance-length instance))
          (layout (sb-kernel:%instance-layout instance))
          (nuntagged (sb-kernel:layout-n-untagged-slots layout)))
@@ -735,7 +757,7 @@
           (seek ctx pos)
           (write-sequence data (ctx-stream ctx)))))))
 
-(defun dump-non-simple-fun (object ctx pos)
+(defun dump-closure (object ctx pos)
   (let ((len (sb-kernel:get-closure-length object)))
     (incf (ctx-position ctx) (* (1+ len) +n+))
     (lambda ()

Modified: trunk/sb-heapdump/relocate.c
==============================================================================
--- trunk/sb-heapdump/relocate.c	(original)
+++ trunk/sb-heapdump/relocate.c	Sat Aug 25 17:10:48 2007
@@ -468,6 +468,7 @@
                 sub_relocate((void *) &fun->name, 1, ctx);
                 sub_relocate((void *) &fun->arglist, 1, ctx);
                 sub_relocate((void *) &fun->type, 1, ctx);
+                sub_relocate((void *) &fun->xrefs, 1, ctx);
                 ep = fun->next;
         }
 
@@ -611,13 +612,11 @@
         reloctab[SIMPLE_FUN_HEADER_WIDETAG] = relocate_lose;
         reloctab[RETURN_PC_HEADER_WIDETAG] = relocate_lose;
 #endif
+        reloctab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = RELOCATE_BOXED;
 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
         reloctab[CLOSURE_HEADER_WIDETAG] = relocate_closure_header;
-        reloctab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG]
-                = relocate_closure_header;
 #else
         reloctab[CLOSURE_HEADER_WIDETAG] = RELOCATE_BOXED;
-        reloctab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = RELOCATE_BOXED;
 #endif
         reloctab[VALUE_CELL_HEADER_WIDETAG] = RELOCATE_BOXED;
         reloctab[SYMBOL_HEADER_WIDETAG] = RELOCATE_BOXED;