/[steeldump]/trunk/sb-heapdump/dump.lisp
ViewVC logotype

Diff of /trunk/sb-heapdump/dump.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 19 by dlichteblau, Sun Aug 27 19:43:29 2006 UTC revision 20 by dlichteblau, Sat Aug 25 21:10:48 2007 UTC
# Line 58  Line 58 
58    (worklist (error "oops"))    (worklist (error "oops"))
59    (worklist-tail (error "oops")))    (worklist-tail (error "oops")))
60    
61    (defmethod print-object ((object ctx) stream)
62      (print-unreadable-object (object stream)))
63    
64  (defvar *disable-customizer* nil)  (defvar *disable-customizer* nil)
65  (defconstant +invalid+ 0)  (defconstant +invalid+ 0)
66    
# Line 77  Line 80 
80    (with-open-file (s pathname    (with-open-file (s pathname
81                     :direction :output                     :direction :output
82                     :element-type '(unsigned-byte 8)                     :element-type '(unsigned-byte 8)
83                       :if-does-not-exist :create
84                     ;; Argh!  SBCL implements :append as O_APPEND, even though                     ;; Argh!  SBCL implements :append as O_APPEND, even though
85                     ;; the Hyperspec says to position the file pointer at                     ;; the Hyperspec says to position the file pointer at
86                     ;; the end of the file *initially*.                     ;; the end of the file *initially*.
# Line 497  Line 501 
501        (dump-unboxed object ctx pos))        (dump-unboxed object ctx pos))
502      ((or symbol ratio complex)      ((or symbol ratio complex)
503        (dump-boxed object ctx pos))        (dump-boxed object ctx pos))
504        (sb-kernel:funcallable-instance
505          (dump-funcallable-instance object ctx pos))
506      (simple-vector (dump-simple-vector object ctx pos))      (simple-vector (dump-simple-vector object ctx pos))
507      ((simple-array * (*)) (dump-primitive-vector object ctx pos))      ((simple-array * (*)) (dump-primitive-vector object ctx pos))
508      (array (dump-boxed object ctx pos))      (array (dump-boxed object ctx pos))
509      (sb-kernel:instance (dump-instance object ctx pos))      (sb-kernel:instance (dump-instance object ctx pos))
510      (sb-kernel:code-component (dump-code-component object ctx pos))      (sb-kernel:code-component (dump-code-component object ctx pos))
511      (function (dump-non-simple-fun object ctx pos))      (function (dump-closure object ctx pos))
512      (sb-kernel:fdefn (dump-fdefn object ctx pos))      (sb-kernel:fdefn (dump-fdefn object ctx pos))
513      (sb-ext:weak-pointer      (sb-ext:weak-pointer
514        (multiple-value-bind (value alive)        (multiple-value-bind (value alive)
# Line 543  Line 549 
549          (dolist (slot slots)          (dolist (slot slots)
550            (write-word slot ctx))))))            (write-word slot ctx))))))
551    
552    (defun dump-funcallable-instance (object ctx pos)
553      (let ((len (sb-kernel:get-closure-length object)))
554        (incf (ctx-position ctx) (* (1+ len) +n+))
555        (lambda ()
556          (let ((slots
557                 (loop
558                    for i from 1 to len
559                    collect
560                      (sub-dump-object (object-ref-lispobj object i) ctx))))
561            (seek ctx pos)
562            (write-word (make-header-word len (sb-kernel:widetag-of object)) ctx)
563            (dolist (slot slots)
564              (write-word slot ctx))))))
565    
566  (defun dump-unboxed (object ctx pos)  (defun dump-unboxed (object ctx pos)
567    (let ((len (sb-kernel:get-header-data object)))    (let ((len (sb-kernel:get-header-data object)))
568      (incf (ctx-position ctx) (* (1+ len) +n+))      (incf (ctx-position ctx) (* (1+ len) +n+))
# Line 590  Line 610 
610      nil))      nil))
611    
612  (defun dump-instance (instance ctx pos)  (defun dump-instance (instance ctx pos)
613      (when (typep instance 'hash-table)
614        (assert (not (sb-impl::hash-table-weakness instance))))
615    (let* ((len (sb-kernel:%instance-length instance))    (let* ((len (sb-kernel:%instance-length instance))
616           (layout (sb-kernel:%instance-layout instance))           (layout (sb-kernel:%instance-layout instance))
617           (nuntagged (sb-kernel:layout-n-untagged-slots layout)))           (nuntagged (sb-kernel:layout-n-untagged-slots layout)))
# Line 735  Line 757 
757            (seek ctx pos)            (seek ctx pos)
758            (write-sequence data (ctx-stream ctx)))))))            (write-sequence data (ctx-stream ctx)))))))
759    
760  (defun dump-non-simple-fun (object ctx pos)  (defun dump-closure (object ctx pos)
761    (let ((len (sb-kernel:get-closure-length object)))    (let ((len (sb-kernel:get-closure-length object)))
762      (incf (ctx-position ctx) (* (1+ len) +n+))      (incf (ctx-position ctx) (* (1+ len) +n+))
763      (lambda ()      (lambda ()

Legend:
Removed from v.19  
changed lines
  Added in v.20

  ViewVC Help
Powered by ViewVC 1.1.5