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;
