[steeldump-cvs] r3 - in trunk: sb-heapdump sb-heapdump/CVS scripts
dlichteblau at common-lisp.net
dlichteblau at common-lisp.net
Sun May 21 18:31:58 UTC 2006
Author: dlichteblau
Date: Sun May 21 14:31:55 2006
New Revision: 3
Added:
trunk/sb-heapdump/
trunk/sb-heapdump/CVS/
trunk/sb-heapdump/CVS/Entries
trunk/sb-heapdump/CVS/Repository
trunk/sb-heapdump/CVS/Root
trunk/sb-heapdump/Makefile
trunk/sb-heapdump/NEWS
trunk/sb-heapdump/common.lisp
trunk/sb-heapdump/demo.lisp
trunk/sb-heapdump/dump.lisp
trunk/sb-heapdump/generation.h
trunk/sb-heapdump/load.lisp
trunk/sb-heapdump/module.lisp
trunk/sb-heapdump/pack.lisp
trunk/sb-heapdump/package.lisp
trunk/sb-heapdump/patch.lisp
trunk/sb-heapdump/relocate.c
trunk/sb-heapdump/sb-heapdump.asd
trunk/sb-heapdump/sb-heapdump.texinfo
trunk/sb-heapdump/test.lisp
trunk/sb-heapdump/testpack.lisp
trunk/sb-heapdump/trampoline.c
Modified:
trunk/scripts/fetch-sbcl
Log:
mirror of private sb-heapdump repository
Added: trunk/sb-heapdump/CVS/Entries
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/CVS/Entries Sun May 21 14:31:55 2006
@@ -0,0 +1,18 @@
+/Makefile/1.1/Sun Jan 22 15:42:49 2006//
+/NEWS/1.9/Thu Feb 2 17:41:48 2006//
+/common.lisp/1.23/Tue Jan 31 20:33:09 2006//
+/demo.lisp/1.31/Sun May 21 12:35:09 2006//
+/dump.lisp/1.62/Wed Apr 26 20:13:23 2006//
+/generation.h/1.2/Sun Jan 22 16:39:15 2006//
+/load.lisp/1.47/Wed Apr 26 20:13:24 2006//
+/module.lisp/1.6/Thu Feb 2 22:26:27 2006//
+/pack.lisp/1.23/Sun May 21 13:15:48 2006//
+/package.lisp/1.10/Sun Jan 22 16:39:15 2006//
+/patch.lisp/1.2/Thu Feb 2 16:04:23 2006//
+/relocate.c/1.18/Wed Apr 26 20:13:24 2006//
+/sb-heapdump.asd/1.10/Tue Jan 31 20:33:09 2006//
+/sb-heapdump.texinfo/1.8/Thu Feb 2 22:26:27 2006//
+/test.lisp/1.26/Tue Jan 31 20:33:09 2006//
+/testpack.lisp/1.4/Sun Jan 22 20:30:20 2006//
+/trampoline.c/1.4/Tue Jan 31 20:33:09 2006//
+D
Added: trunk/sb-heapdump/CVS/Repository
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/CVS/Repository Sun May 21 14:31:55 2006
@@ -0,0 +1 @@
+sb-heapdump
Added: trunk/sb-heapdump/CVS/Root
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/CVS/Root Sun May 21 14:31:55 2006
@@ -0,0 +1 @@
+/home/david/cvsroot
Added: trunk/sb-heapdump/Makefile
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/Makefile Sun May 21 14:31:55 2006
@@ -0,0 +1,16 @@
+CFLAGS=-I../../src/runtime/ -Wall -O2
+EXTRA_ALL_TARGETS=it
+
+SYSTEM=sb-heapdump
+include ../asdf-module.mk
+
+it: trampoline relocate.so
+
+relocate.so: relocate.o
+ gcc -shared -o $@ $^
+
+trampoline: trampoline.o
+ gcc -o $@ $^ -lm
+
+%.o: %.c
+ gcc $(CFLAGS) -c -fPIC -o $@ $<
Added: trunk/sb-heapdump/NEWS
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/NEWS Sun May 21 14:31:55 2006
@@ -0,0 +1,27 @@
+Changes in sb-heapdump-05
+ * x86-64 fixes
+ * PowerPC/cheneygc port
+ * alien fixups
+
+Changes in sb-heapdump-04
+ * s/:supersede/:rename-and-delete/, because SBCL does not, as the spec
+ says, create a *new* file under the old name, but rather overwrites
+ the data in the old file using O_TRUNC! Not a good idea when the
+ file in question is currently mapped into dynamic space!
+ * convenience function DUMP-SYSTEM for ASDF systems
+ * MAKE-EXECUTABLE hack
+ * allow .heap files to be concatenated
+ * don't duplicate SB-IMPL::*PHYSICAL-HOST*
+
+Changes in sb-heapdump-03
+ * support for SAPs
+ * support for weak pointers
+ * avoid recomputing gf dfuns multiple times
+ * mark hash tables for rehashing if a hash value is eq-based
+ * keep an explicit worklist to avoid overflowing the stack for deep graphs
+ * fixed CTORs (ensure-ctor sometimes returns NIL...)
+ * user fixups; removed :PARAMETERS in favour of :CUSTOMIZER
+ * new howto: climacs
+ * relocate heap files manually instead of relying on GC, eliminating
+ the need for a patch to SBCL and allowing files to be mapped without
+ any relocation if the targeted space is free.
Added: trunk/sb-heapdump/common.lisp
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/common.lisp Sun May 21 14:31:55 2006
@@ -0,0 +1,71 @@
+;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; Copyright (c) 2006 David Lichteblau
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation files
+;;; (the "Software"), to deal in the Software without restriction,
+;;; including without limitation the rights to use, copy, modify, merge,
+;;; publish, distribute, sublicense, and/or sell copies of the Software,
+;;; and to permit persons to whom the Software is furnished to do so,
+;;; subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;;; SOFTWARE.
+
+(in-package :sb-heapdump)
+
+(defconstant +n+ sb-vm:n-word-bytes)
+(defconstant +2n+ (* 2 +n+))
+
+(defstruct (header (:type vector))
+ object
+ fixups
+ initializer
+ customizer)
+
+(macrolet ((doit (&rest names)
+ `(progn
+ (defvar *fixup-names* ,(coerce names 'vector))
+ ,@(loop
+ for name in names
+ for i from 0
+ collect `(defconstant ,name ,i)))))
+ ;; order matters
+ (doit +package-fixup+
+ +symbol-fixup+
+ +classoid-fixup+
+ +layout-fixup+
+ +fdefn-fixup+
+ +named-type-fixup+
+ +array-type-fixup+
+ +class-fixup+
+ +function-fixup+
+ +ctor-fixup+
+ +slot-accessor-fixup+
+ +fast-method-fixup+
+ +raw-address-fixup+
+ +variable-fixup+
+ +foreign-fixup+
+ +user-fixup+))
+
+(defstruct (fixup
+ (:type vector)
+ (:constructor make-fixup (type id))
+ (:constructor make-symbol-fixup (type id2 id))
+ (:constructor make-fast-method-fixup (type id id2))
+ (:constructor make-foreign-fixup (type id id2))
+ (:constructor make-user-fixup (type id id2)))
+ type
+ id
+ id2
+ locations)
Added: trunk/sb-heapdump/demo.lisp
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/demo.lisp Sun May 21 14:31:55 2006
@@ -0,0 +1,236 @@
+;;; -*- indent-tabs-mode: nil -*-
+
+;;; Sample DUMP-SYSTEM implementations for some ASDF systems
+
+;;; FIXME: To dump a system defining generic functions (like McCLIM)
+;;; that a different system adds methods to (like Climacs), make sure to
+;;; dump the former system before loading the latter.
+;;;
+;;; Otherwise there will be unresolvable references to Climacs functions
+;;; in the dumpfile for McCLIM.
+
+
+(defmethod sb-heapdump:dump-system ((c (eql (asdf:find-system :xmls))))
+ (sb-heapdump:dump-packages :xmls "xmls.heap" :if-exists :rename-and-delete))
+
+
+(defmethod sb-heapdump:dump-system ((c (eql (asdf:find-system :cxml))))
+ (sb-heapdump:dump-packages
+ '("RUNE-DOM" "RUNES" "RUNES-ENCODING" "UTF8-RUNES" "CXML" "SAX" "DOM"
+ "UTF8-DOM" "CXML-XMLS" "DOMTEST" "XMLCONF" "DOMTEST-TESTS")
+ "test.heap"
+ :if-exists :rename-and-delete
+ :systems '(:cxml-runes :cxml-xml :cxml-dom :cxml-test :cxml)
+ :system-packages '(:cxml-system)))
+
+
+(defmethod sb-heapdump:dump-system ((c (eql (asdf:find-system :clx))))
+ (sb-heapdump:dump-packages
+ ;; The test stuff is apparently loaded only when compiling clx for the
+ ;; first time (and must then be dumped, too), not when loading clx later(?).
+ ;; Let's just ignore the non-existent package for now.
+ (remove nil (mapcar #'find-package '(:gl :glx :xlib :clipboard :gl-test)))
+ "clx.heap"
+ :if-exists :rename-and-delete
+ :initializer (let ((event-keys xlib::*event-key-vector*))
+ (lambda (packages)
+ (loop
+ for event-key across event-keys
+ for i from 0
+ do
+ (setf (get event-key 'xlib::event-code) i))
+ (setf *features*
+ (union *features*
+ '(:clx-ext-render
+ :clx-mit-r5
+ :clx-mit-r4
+ :xlib
+ :clx
+ :clx-little-endian
+ :clx-ansi-common-lisp)))
+ packages))
+ :systems '(:clx)
+ :system-packages '(:clx-system)))
+
+#|
+(load "/home/david/src/lisp/clx_0.7.1/demo/menu")
+(xlib::just-say-lisp)
+|#
+
+(defmethod sb-heapdump:dump-system ((c (eql (asdf:find-system :mcclim))))
+ (let ((packages
+ (mapcar #'find-package
+ '("IMAGE" "CLIM-CLX" "CLIM-XCOMMON" "CLIM-POSTSCRIPT"
+ "CLIM-FFI" "GOATEE" "CLIM-USER" "CLIM-DEMO"
+ "CLIM-INTERNALS" "CLIM-BACKEND" "CLIM-EXTENSIONS"
+ "CLIM-SYS" "CLIM" "CLIM-LISP" "CLIM-MOP"
+ "CLIM-LISP-PATCH"))))
+ (sb-heapdump:dump-packages
+ packages
+ "mcclim.heap"
+ :if-exists :rename-and-delete
+ ;; Pfui, dagegen ist CLX ja noch brav und benutzt einen Indicator
+ ;; aus seinem eigenen Paket.
+ :initializer (let* ((ports climi::*server-path-search-order*)
+ (types
+ (loop
+ for port in ports
+ collect (get port :port-type)))
+ (parsers
+ (loop
+ for port in ports
+ collect (get port :server-path-parser))))
+ (lambda (x)
+ (loop
+ for port in ports
+ for type in types
+ for parser in parsers
+ do
+ (setf (get port :port-type) type)
+ (setf (get port :server-path-parser) parser))
+ (pushnew :clim *features*)
+ (pushnew :mcclim *features*)
+ x))
+ :systems '(:mcclim :clim :clim-lisp :clim-core :goatee-core
+ :clim-postscript :clim-clx :clim-opengl
+ :clim-objc-support :clim-beagle :clim-looks
+ :clim-clx-user :clim-examples :scigraph
+ :clim-listener)
+ :system-packages '(:mcclim.system))))
+
+
+(defun dump-clim-application
+ (packages pathname
+ &rest args &key (initializer #'identity) force &allow-other-keys)
+ (let ((p (mapcar #'find-package packages)))
+ (flet ((extract-hash-table (sym)
+ (let ((hash-table (symbol-value sym))
+ (alist '()))
+ (maphash (lambda (k v)
+ (when (member (symbol-package k) p)
+ (when (typep v 'class)
+ (pushnew (class-name v) force))
+ (push (cons k v) alist)))
+ hash-table)
+ (cons sym alist)))
+ (restore-hash-table (x)
+ (let ((table (symbol-value (car x))))
+ (loop for (k . v) in (cdr x) do (setf (gethash k table) v))))
+ ;; climacs-specific hack to find anonymous command tables
+ (extract-climacs-tables (sym)
+ (let ((hash-table (symbol-value sym))
+ (anonymous-command-tables '())
+ (alist '()))
+ (maphash (lambda (k v)
+ (when (member (symbol-package k) p)
+ (dolist (mi (slot-value v 'climi::keystroke-items))
+ (pushnew (clim:command-menu-item-value
+ (clim:menu-item-value mi))
+ anonymous-command-tables))))
+ hash-table)
+ (dolist (name anonymous-command-tables)
+ (push (cons name (gethash name hash-table)) alist))
+ (cons sym alist))))
+ (let ((data
+ (list
+ (extract-hash-table 'climi::*command-tables*)
+ (extract-climacs-tables 'climi::*command-tables*)
+ (extract-hash-table 'climi::*command-parser-table*)
+ (extract-hash-table 'climi::*presentation-type-table*)
+ (extract-hash-table 'climi::*presentation-type-abbreviations*))))
+ (apply #'sb-heapdump:dump-packages
+ packages
+ pathname
+ :force (cons #'dump-clim-application force)
+ :initializer (lambda (x)
+ (mapc #'restore-hash-table data)
+ (funcall initializer x))
+ ;; CLIM wants the +foo-ink+s to be unique objects.
+ :customizer (lambda (object)
+ (dolist (var '(climi::*unsupplied-argument-marker*
+ climi::*numeric-argument-marker*
+ clim:+foreground-ink+
+ clim:+foreground-ink+
+ clim:+background-ink+
+ clim:+flipping-ink+)
+ t)
+ (when (eq object (symbol-value var))
+ (return (values :fixup var)))))
+ :load-time-customizer (lambda (sym ignore)
+ ignore
+ (symbol-value sym))
+ args)))))
+
+(defmethod sb-heapdump:dump-system ((c (eql (asdf:find-system :climacs))))
+ (dump-clim-application
+ '("CLIMACS-SLIDEMACS-EDITOR" "CLIMACS-TTCN3-SYNTAX" "CLIMACS-GUI" "ESA"
+ "CLIMACS-LISP-SYNTAX" "CLIMACS-CL-SYNTAX" "CLIMACS-PROLOG-SYNTAX"
+ "CLIMACS-HTML-SYNTAX" "CLIMACS-FUNDAMENTAL-SYNTAX" "CLIMACS-PANE" "UNDO"
+ "CLIMACS-KILL-RING" "CLIMACS-SYNTAX" "CLIMACS-ABBREV" "CLIMACS-BASE"
+ "CLIMACS-BUFFER" "BINSEQ" "AUTOMATON" "EQV-HASH" "FLEXICHAIN")
+ "climacs.heap"
+ :force (list 'clim:form #'clim:command-table #'(setf clim:command-table))
+ :initializer (lambda (x)
+ (setf (fdefinition 'clim:command-table) #'clim:command-table)
+ (setf (fdefinition '(setf clim:command-table))
+ #'(setf clim:command-table))
+ x)
+ :systems '(:climacs :climacs.tests :flexichain)
+ :system-packages '(:climacs.system :flexichain-system)
+ :if-exists :rename-and-delete))
+
+#|
+(sb-heapdump:relocate-dumpfiles '("clx.heap" "mcclim.heap" "climacs.heap"))
+(sb-heapdump:make-executable "climacs.heap":main-function 'climacs-gui:climacs)
+|#
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; simple DUMP-OBJECT tests
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+#|
+
+(sb-heapdump::dump-object (let ((x (make-hash-table)))
+ (setf (gethash 'foo x) 'bar)
+ x)
+ "test.heap"
+ :if-exists :rename-and-delete)
+
+(sb-heapdump::dump-object (lambda ())
+ "test.heap"
+ :if-exists :rename-and-delete)
+
+(defun ff (x) (if (zerop x) 1 (* x (ff (1- x)))))
+
+(sb-heapdump::dump-object
+ #'ff
+ "test.heap"
+ :force t
+ :if-exists :rename-and-delete)
+
+(sb-heapdump::dump-object
+ '("foo" "bar")
+ "test.heap"
+ :force t
+ :if-exists :rename-and-delete)
+
+(sb-heapdump::dump-object
+ (list (sb-ext:make-weak-pointer :foo))
+ "test.heap"
+ :force t
+ :if-exists :rename-and-delete)
+
+(sb-heapdump::dump-object
+ '("foo" "bar")
+ "test.heap"
+ :initializer #'print
+ :if-exists :rename-and-delete)
+
+(sb-heapdump::dump-object
+ '("baz" "quux")
+ "test.heap"
+ :initializer #'print
+ :if-exists :append)
+
+|#
Added: trunk/sb-heapdump/dump.lisp
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/dump.lisp Sun May 21 14:31:55 2006
@@ -0,0 +1,794 @@
+;;; -*- indent-tabs-mode: nil -*-
+
+;;; Copyright (c) 2006 David Lichteblau
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation files
+;;; (the "Software"), to deal in the Software without restriction,
+;;; including without limitation the rights to use, copy, modify, merge,
+;;; publish, distribute, sublicense, and/or sell copies of the Software,
+;;; and to permit persons to whom the Software is furnished to do so,
+;;; subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;;; SOFTWARE.
+
+(in-package :sb-heapdump)
+
+(sb-alien:define-alien-variable "sizetab" (array (* t) 256))
+
+(defconstant +page-size+
+ #+gencgc sb-vm:gencgc-page-size
+ #-gencgc sb-c:*backend-page-size*)
+
+(defvar *default-base-address*
+ #+gencgc
+ ;; by default, target the center of dynamic space
+ (logandc2 (/ (+ sb-vm:dynamic-space-start sb-vm:dynamic-space-end) 2)
+ (1- +page-size+))
+ #-gencgc
+ ;; will always relocate anyway
+ sb-vm:dynamic-0-space-start)
+
+(defvar *dump-verbose* t)
+(defvar *dump-print* nil)
+
+(defstruct
+ (ctx (:constructor make-ctx (stream stream-start base-address customizer
+ &key (worklist (cons nil nil))
+ (worklist-tail worklist))))
+ stream
+ stream-start
+ base-address
+ (position (* 3 +n+)) ;base address, length, header pointer
+ (fixups '())
+ (force (make-hash-table))
+ customizer
+ (addresses (make-hash-table))
+ (weak-pointers '())
+ (worklist (error "oops"))
+ (worklist-tail (error "oops")))
+
+(defvar *disable-customizer* nil)
+(defconstant +invalid+ 0)
+
+(defun dump-object
+ (object pathname &key (if-exists :error)
+ customizer
+ load-time-customizer
+ force
+ initializer
+ (base-address *default-base-address*)
+ (print-statistics *dump-print*))
+ (when (eq if-exists :supersede)
+ ;; Argh! SBCL implements :supersede as O_TRUNC, even though the Hypersec
+ ;; says explicitly to create a *new* file under the same name instead
+ ;; of overwriting the old one.
+ (setf if-exists :rename-and-delete))
+ (with-open-file (s pathname
+ :direction :output
+ :element-type '(unsigned-byte 8)
+ ;; Argh! SBCL implements :append as O_APPEND, even though
+ ;; the Hyperspec says to position the file pointer at
+ ;; the end of the file *initially*.
+ :if-exists (if (eq if-exists :append) :overwrite if-exists))
+ (when (eq if-exists :append)
+ (file-position s (file-length s)))
+ (let ((ctx (make-ctx s (file-position s) base-address customizer)))
+ (dolist (arg (if (eq force t) (list object) force))
+ (setf (gethash arg (ctx-force ctx)) t))
+ (dump-all object ctx)
+ ;; kludge: wrap the functions in conses, since the header is written
+ ;; after the fixups and cannot itself contain fixups.
+ (when initializer
+ (setf initializer (list initializer))
+ (dump-all initializer ctx))
+ (when load-time-customizer
+ (setf load-time-customizer (list load-time-customizer))
+ (dump-all load-time-customizer ctx))
+ (update-weak-pointers ctx)
+ (unless (integerp (gethash object (ctx-addresses ctx)))
+ (error "argument was replaced by a fixup.~_ Use :FORCE to dump ~
+ this object literally:~_ ~A"
+ object))
+ (let ((*disable-customizer* t))
+ (dump-fixups ctx)
+ (let* ((header
+ (make-header :object object
+ :fixups (ctx-fixups ctx)
+ :customizer load-time-customizer
+ :initializer initializer))
+ (header-address (dump-all header ctx))
+ (file-length (progn (finish-output s) (file-length s)))
+ (length (- file-length (ctx-stream-start ctx)))
+ (padding (- (nth-value 1 (ceiling length +page-size+)))))
+ (file-position s file-length)
+ (dotimes (x padding)
+ (write-byte 0 s))
+ (seek ctx 0)
+ (write-word base-address ctx)
+ (write-word (+ length padding) ctx)
+ (write-word header-address ctx))
+ (when *dump-verbose*
+ (format t "~&~D bytes written~%"
+ (- (file-length s) (ctx-stream-start ctx))))
+ (when print-statistics
+ (print-statistics ctx))))
+ pathname))
+
+(defun dump-all (object ctx)
+ (prog1
+ (sub-dump-object object ctx)
+ (loop while (cdr (ctx-worklist ctx)) do
+ (pop (ctx-worklist ctx))
+ (funcall (car (ctx-worklist ctx))))))
+
+(defconstant +fixup-length+ (* (+ 2 (length (make-fixup nil nil))) +n+))
+
+(defun update-weak-pointers (ctx)
+ (dolist (wp (ctx-weak-pointers ctx))
+ (multiple-value-bind (value alive)
+ (sb-ext:weak-pointer-value wp)
+ (let* ((value-address
+ (when alive
+ (gethash value (ctx-addresses ctx))))
+ (wp-pos (- (logandc2 (gethash wp (ctx-addresses ctx))
+ sb-vm:lowtag-mask)
+ (ctx-base-address ctx))))
+ (seek ctx (+ wp-pos +n+))
+ (cond
+ (value-address
+ ;; value has been dumped, write its address
+ (write-word value-address ctx))
+ (t
+ ;; break it
+ (write-word (sb-kernel:get-lisp-obj-address nil) ctx)
+ (write-word (sb-kernel:get-lisp-obj-address t) ctx)))))))
+
+(defun dump-fixups (ctx)
+ (setf (ctx-fixups ctx) (sort (ctx-fixups ctx) #'< :key #'fixup-type))
+ (let ((fixups (reverse (ctx-fixups ctx)))
+ (fixup-start (align (ctx-position ctx))))
+ (setf (ctx-position ctx) fixup-start)
+ (dolist (f fixups)
+ (setf (gethash f (ctx-addresses ctx))
+ (logior (+ (ctx-base-address ctx) (ctx-position ctx))
+ sb-vm:other-pointer-lowtag))
+ (incf (ctx-position ctx) +fixup-length+))
+ (loop
+ for f in fixups
+ for pos from fixup-start by +fixup-length+
+ do
+ (when *dump-print* (trace-fixup f pos))
+ (setf (fixup-locations f)
+ (coerce
+ (fixup-locations f)
+ `(simple-array (unsigned-byte ,sb-vm:n-word-bits) (*))))
+ (funcall (dump-simple-vector f ctx pos t)))))
+
+(defun simplify-type (type)
+ (cond
+ ((and (listp type)
+ (eq (car type) 'simple-array)
+ (subtypep (second type) 'integer))
+ '(simple-array "subtype of integer"))
+ ((and (subtypep type 'simple-array) (listp type))
+ (list (car type) "something or other"))
+ (t
+ type)))
+
+(defun print-statistics (ctx)
+ (let* ((n (length *fixup-names*))
+ (fixup-types (make-array n :initial-element 0))
+ (fixup-locations (make-array n :initial-element 0)))
+ (format t "~&fixups by type:~%")
+ (dolist (f (ctx-fixups ctx))
+ (incf (elt fixup-types (fixup-type f)))
+ (incf (elt fixup-locations (fixup-type f)) (length (fixup-locations f))))
+ (loop
+ for type across *fixup-names*
+ for n across fixup-types
+ for locations across fixup-locations
+ do
+ (when (plusp n)
+ (format t "~10D ~A (~D locations)~%" n type locations))))
+ (let ((types (make-hash-table :test 'equal)))
+ (maphash (lambda (object address)
+ (when (integerp address)
+ (incf (gethash (simplify-type (type-of object)) types 0))))
+ (ctx-addresses ctx))
+ (format t "~&number of objects by type:~%")
+ (let ((stats '()))
+ (maphash (lambda (type n) (push (cons type n) stats)) types)
+ (loop for (type . n) in (sort stats #'> :key #'cdr) do
+ (format t "~10D ~S~%" n type)))))
+
+(defun write-word (object ctx)
+ (unless (integerp object)
+ (push (tell ctx) (fixup-locations object))
+ (setf object +invalid+))
+ (%write-word object (ctx-stream ctx)))
+
+(defun %write-word (object s)
+ (declare (optimize (sb-ext:inhibit-warnings 3)))
+ (if #.(eq sb-c::*backend-byte-order* :big-endian)
+ (loop
+ for i from (- sb-vm:n-word-bits 8) downto 0 by 8
+ do (write-byte (ldb (byte 8 i) object) s))
+ (loop
+ for i from 0 below sb-vm:n-word-bits by 8
+ do (write-byte (ldb (byte 8 i) object) s))))
+
+(defun seek (ctx pos)
+ (file-position (ctx-stream ctx) (+ (ctx-stream-start ctx) pos)))
+
+(defun tell (ctx)
+ (- (file-position (ctx-stream ctx)) (ctx-stream-start ctx)))
+
+(defun native-address (object)
+ (logandc2 (sb-kernel:get-lisp-obj-address object) sb-vm:lowtag-mask))
+
+(defun native-pointer (object)
+ (sb-sys:int-sap (native-address object)))
+
+(defun make-header-word (data widetag)
+ (logior (ash data sb-vm:n-widetag-bits) widetag))
+
+(defun object-ref-word (object index)
+ (sb-sys:without-gcing
+ (sb-sys:sap-ref-word (native-pointer object) (* index +n+))))
+
+(defun (setf object-ref-word) (newval object index)
+ (sb-sys:without-gcing
+ (setf (sb-sys:sap-ref-word (native-pointer object) (* index +n+))
+ newval)))
+
+(defun object-ref-lispobj (object index)
+ (sb-sys:without-gcing
+ (sb-kernel:make-lisp-obj
+ (sb-sys:sap-ref-word (native-pointer object) (* index +n+)))))
+
+(defun align (address)
+ (- address (nth-value 1 (ceiling address (1+ sb-vm:lowtag-mask)))))
+
+(defun make-address (raw-pointer lowtag)
+ (logior raw-pointer lowtag))
+
+(defun forcep (object ctx)
+ (or (gethash object (ctx-force ctx))
+ (etypecase object
+ (package nil)
+ (symbol
+ (or (null (symbol-package object))
+ (forcep (symbol-package object) ctx)))
+ (sb-kernel:classoid (forcep (sb-kernel:classoid-name object) ctx))
+ (sb-kernel:layout (forcep (sb-kernel:layout-classoid object) ctx))
+ (sb-kernel:fdefn
+ (let ((name (sb-kernel:fdefn-name object)))
+ (or (not (fixupable-function-p
+ (sb-kernel:fdefn-fun object)
+ name
+ ctx))
+ ;; fixme: isn't this vaguely like !fixupable-function-p (but
+ ;; worse, not exactly the same)? Should it be?
+ (typecase name
+ (symbol (and (symbolp name) (forcep name ctx)))
+ (list
+ (or (some (lambda (x) (and (symbolp x) (forcep x ctx)))
+ name)
+ ;; always dump ctor fdefns
+ (eq 'sb-pcl::ctor (car name))
+ ;; ditto for accessors
+ (eq 'sb-pcl::slot-accessor (car name))))
+ (t nil)))))
+ (sb-kernel:named-type
+ (let ((name (sb-kernel:named-type-name object)))
+ (and (symbolp name) (forcep name ctx))))
+ (sb-kernel:array-type
+ nil)
+ (class
+ (or (not (slot-boundp object 'sb-pcl::name)) ;argh. FIXME!
+ (forcep (class-name object) ctx)))
+ (function nil))))
+
+(defun slot-accessor-p (gf)
+ (let ((x (sb-mop:generic-function-name gf)))
+ (and (listp x) (eq (car x) 'sb-pcl::slot-accessor))))
+
+(defun dump-fixup (object ctx)
+ (let ((fixup
+ (etypecase object
+ (package
+ (make-fixup +package-fixup+ (package-name object)))
+ (symbol
+ (make-symbol-fixup
+ +symbol-fixup+
+ (symbol-package object)
+ (symbol-name object)))
+ (sb-kernel:classoid
+ (make-fixup +classoid-fixup+ (sb-kernel:classoid-name object)))
+ (sb-kernel:layout
+ (make-fixup +layout-fixup+ (sb-kernel:layout-classoid object)))
+ (sb-kernel:fdefn
+ (make-fixup +fdefn-fixup+ (sb-kernel:fdefn-name object)))
+ (sb-kernel:named-type
+ (make-fixup +named-type-fixup+
+ (sb-kernel:named-type-name object)))
+ (sb-kernel:array-type
+ (make-fixup +array-type-fixup+
+ (list :dimensions
+ (sb-kernel::array-type-dimensions object)
+ :complexp
+ (sb-kernel::array-type-complexp object)
+ :element-type
+ (sb-kernel::array-type-element-type object)
+ :specialized-element-type
+ (sb-kernel::array-type-specialized-element-type
+ object))))
+ (class (make-fixup +class-fixup+ (class-name object)))
+ (generic-function
+ (if (slot-accessor-p object)
+ (make-fixup +slot-accessor-fixup+
+ (sb-mop:generic-function-name object))
+ (make-fixup +function-fixup+
+ (sb-mop:generic-function-name object))))
+ (sb-pcl::ctor
+ (make-fixup +ctor-fixup+
+ (list* (sb-pcl::ctor-function-name object)
+ (sb-pcl::ctor-class-name object)
+ (sb-pcl::ctor-initargs object))))
+ (function
+ ;; murmeltypsicheresprachemurmel
+ (assert (eql (sb-kernel:widetag-of object)
+ sb-vm:simple-fun-header-widetag))
+ (make-fixup +function-fixup+
+ (sb-kernel:%simple-fun-name object))))))
+ (setf (gethash object (ctx-addresses ctx)) fixup)
+ (%build-fixup fixup ctx)))
+
+(defun %build-fixup (fixup ctx)
+ (let ((*disable-customizer* t))
+ (sub-dump-object (fixup-id fixup) ctx)
+ (sub-dump-object (fixup-id2 fixup) ctx))
+ (push fixup (ctx-fixups ctx))
+ fixup)
+
+(defun trace-fixup (object pos)
+ (format *trace-output* "~&~8,'0X [~A] ~A ~A~{ #x~X~}~%"
+ pos
+ (elt *fixup-names* (fixup-type object))
+ (fixup-id object)
+ (fixup-id2 object)
+ (fixup-locations object)))
+
+(defun trace-object (object ctx)
+ (format *trace-output* "~&~8,'0X " (ctx-position ctx))
+ (if (and *disable-customizer*
+ (typep object 'simple-vector)
+ (not (stringp object))
+ (/= (length object)
+ (load-time-value (length (make-fixup -1 nil)))))
+ (format *trace-output* "[FILE HEADER] ")
+ (handler-case
+ (write object
+ :stream *trace-output*
+ :pretty nil
+ :escape t
+ :circle t
+ :level 3
+ :length 4)
+ (serious-condition (c)
+ (ignore-errors (format *trace-output* "printer error: ~A" c)))))
+ (fresh-line *trace-output*))
+
+(defun function-name-identifier (name)
+ (cond
+ ((symbolp name)
+ name)
+ ((and (listp name)
+ (eq (car name) 'setf)
+ (symbolp (second name)))
+ (second name))))
+
+(defun fixupable-function-p (fn name ctx)
+ (let ((id (function-name-identifier name)))
+ (and (not (forcep fn ctx)) ;fixme: check other entry-points, too?
+ id
+ (not (forcep id ctx))
+ (not (and (listp name) (eq (car name) 'sb-pcl::fast-method)))
+ (let ((fdefn (sb-int:info :function :definition name)))
+ (and fdefn (eq fn (sb-kernel:fdefn-fun fdefn)))))))
+
+(defun sub-dump-object (object ctx &key fixup-only)
+ (cond
+ ;; already seen
+ ((gethash object (ctx-addresses ctx)))
+ ;; immediate
+ ((or (null object)
+ (eq object t)
+ (evenp (sb-kernel:lowtag-of object)))
+ (sb-kernel:get-lisp-obj-address object))
+ ;; customizer/user-defined fixups
+ ((and (ctx-customizer ctx)
+ (not *disable-customizer*)
+ (multiple-value-bind (dumpp data1 data2)
+ (funcall (ctx-customizer ctx) object)
+ (ecase dumpp
+ ((t) nil)
+ ((nil)
+ (setf (gethash object (ctx-addresses ctx))
+ (sub-dump-object data1 ctx :fixup-only fixup-only)))
+ (:fixup
+ (let ((fixup (make-user-fixup +user-fixup+ data1 data2)))
+ (%build-fixup fixup ctx)
+ (setf (gethash object (ctx-addresses ctx)) fixup)))))))
+ ;; other fixup, unless overriden
+ ((and (typep object '(or package symbol class sb-kernel:layout
+ sb-kernel:classoid sb-kernel:fdefn
+ sb-kernel:named-type sb-kernel:array-type))
+ (not (forcep object ctx)))
+ (dump-fixup object ctx))
+ ;; functions
+ ((and (functionp object)
+ (eql (sb-kernel:widetag-of object) sb-vm:simple-fun-header-widetag))
+ ;; Funktionsobjekte muessten wir eigentlich dumpen, weil sie nicht
+ ;; in dem Sinne eindeutig sind. Wenn wir aber eine Funktion finden,
+ ;; die tatsaechlich so exakt wieder ueber ihren Namen auffindbar ist,
+ ;; dumpen wir mal opportunistisch doch ein Fixup um Platz zu sparen.
+ ;; In vielen Faellen sollte das so ohnehin richtiger sein.
+ (cond
+ ((fixupable-function-p object
+ (sb-kernel:%simple-fun-name object)
+ ctx)
+ (dump-fixup object ctx))
+ (t
+ (when fixup-only
+ (return-from sub-dump-object nil))
+ (sub-dump-object (simple-fun-code-object object) ctx)
+ (gethash object (ctx-addresses ctx)))))
+ ((and (typep object 'generic-function)
+ (slot-boundp object 'sb-pcl::name)
+ (or (slot-accessor-p object) ;never dump slot accessors
+ (fixupable-function-p object
+ (sb-mop:generic-function-name object)
+ ctx)))
+ (dump-fixup object ctx))
+ ((typep object 'sb-pcl::ctor)
+ ;; never dump ctors
+ (dump-fixup object ctx))
+ ((eq object sb-impl::*physical-host*)
+ (let ((fixup (make-fixup +variable-fixup+ 'sb-impl::*physical-host*)))
+ (setf (gethash object (ctx-addresses ctx)) fixup)
+ (%build-fixup fixup ctx)))
+ ;; ordinary dumpable objects
+ (t
+ (when fixup-only
+ (return-from sub-dump-object nil))
+ (setf (ctx-position ctx) (align (ctx-position ctx)))
+ (when *dump-print*
+ (trace-object object ctx))
+ (let* ((pos (ctx-position ctx))
+ (address
+ (make-address (+ (ctx-base-address ctx) pos)
+ (sb-kernel:lowtag-of object))))
+ (setf (gethash object (ctx-addresses ctx)) address)
+ (let ((fn (dump-nonfixup object ctx pos)))
+ (when fn
+ (push fn (cdr (ctx-worklist-tail ctx)))
+ (setf (ctx-worklist-tail ctx)
+ (cdr (ctx-worklist-tail ctx)))))
+ address))))
+
+(defun dump-nonfixup (object ctx pos)
+ (typecase object
+ (cons (dump-cons object ctx pos))
+ ((or integer single-float double-float (complex single-float)
+ (complex double-float) #+long-float (complex long-float)
+ sb-sys:system-area-pointer)
+ (dump-unboxed object ctx pos))
+ ((or symbol ratio complex)
+ (dump-boxed 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))
+ (sb-kernel:fdefn (dump-fdefn object ctx pos))
+ (sb-ext:weak-pointer
+ (multiple-value-bind (value alive)
+ (sb-ext:weak-pointer-value object)
+ (prog1
+ (dump-unboxed object ctx pos)
+ (when alive
+ (sub-dump-object value ctx
+ ;; don't dump the actual value here, but
+ ;; if it's fixupable, dump the fixup to avoid
+ ;; breaking the reference needlessly
+ :fixup-only t)
+ (push object (ctx-weak-pointers ctx))))))
+ (t
+ (if (sb-di::indirect-value-cell-p object)
+ (dump-boxed object ctx pos)
+ (error "cannot dump object ~S" object)))))
+
+(defun dump-cons (object ctx pos)
+ (incf (ctx-position ctx) +2n+)
+ (lambda ()
+ (let ((car (sub-dump-object (car object) ctx))
+ (cdr (sub-dump-object (cdr object) ctx)))
+ (seek ctx pos)
+ (write-word car ctx)
+ (write-word cdr ctx))))
+
+(defun dump-boxed (object ctx pos)
+ (let ((len (sb-kernel:get-header-data 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+))
+ (seek ctx pos)
+ (dotimes (i (1+ len))
+ (write-word (object-ref-word object i) ctx))
+ nil))
+
+(defun dump-simple-vector (object ctx pos &optional fixup)
+ (let ((length (length object))
+ (header (sb-kernel:get-header-data object)))
+ (when (eql header sb-vm:vector-valid-hashing-subtype)
+ (let ((fn (sb-impl::hash-table-hash-fun (aref object 0))))
+ (when (loop
+ for k being each hash-key in (aref object 0)
+ thereis (nth-value 1 (funcall fn k)))
+ (setf header sb-vm:vector-must-rehash-subtype))))
+ (unless fixup
+ (incf (ctx-position ctx) (* (+ 2 length) +n+)))
+ (lambda ()
+ (let ((elements (map 'vector
+ (lambda (elt) (sub-dump-object elt ctx))
+ object)))
+ (seek ctx pos)
+ (write-word (make-header-word header (sb-kernel:widetag-of object))
+ ctx)
+ (write-word (sb-vm:fixnumize length) ctx)
+ (loop for elt across elements do
+ (write-word elt ctx))))))
+
+(defun size-of (object)
+ (sb-sys:with-pinned-objects (object)
+ (sb-alien:with-alien
+ ((fn (* (function sb-alien:long (* t)))
+ (sb-sys:sap-ref-sap (sb-alien:alien-sap sizetab)
+ (* +n+ (sb-kernel:widetag-of object)))))
+ (sb-alien:alien-funcall fn (native-pointer object)))))
+
+(defun dump-primitive-vector (object ctx pos)
+ (let ((full-length (align (* +n+ (size-of object)))))
+ (incf (ctx-position ctx) full-length)
+ (seek ctx pos)
+ (dotimes (i (truncate full-length +n+))
+ (write-word (object-ref-word object i) ctx))
+ nil))
+
+(defun dump-instance (instance ctx pos)
+ (let* ((len (sb-kernel:%instance-length instance))
+ (layout (sb-kernel:%instance-layout instance))
+ (nuntagged (sb-kernel:layout-n-untagged-slots layout)))
+ (incf (ctx-position ctx) (* (1+ len) +n+))
+ (lambda ()
+ (let* ((slots
+ (loop
+ for i from 0 below (- len nuntagged)
+ collect
+ (sub-dump-object (sb-kernel:%instance-ref instance i)
+ ctx)))
+ (l (pop slots)))
+ (seek ctx pos)
+ (write-word (make-header-word len sb-vm:instance-header-widetag) ctx)
+ (cond
+ ((integerp l)
+ (write-word l ctx))
+ (t
+ ;; if replaced with a fixup, store nuntagged here, so that
+ ;; relocation knows what to da
+ (push (tell ctx) (fixup-locations l))
+ (write-word (sb-vm:fixnumize nuntagged) ctx)))
+ (dolist (slot slots)
+ (write-word slot ctx))
+ (dotimes (i nuntagged)
+ (write-word
+ (sb-kernel:%raw-instance-ref/word instance (- nuntagged i 1))
+ ctx))))))
+
+(defun simple-fun-code-object (fun)
+ (sb-sys:with-pinned-objects (fun)
+ (let* ((fun-sap (native-pointer fun))
+ (header-value
+ (ash (sb-sys:sap-ref-word fun-sap 0) (- sb-vm:n-widetag-bits))))
+ (sb-kernel:make-lisp-obj
+ (logior (- (sb-sys:sap-int fun-sap) (* header-value +n+))
+ sb-vm:other-pointer-lowtag)))))
+
+;; fixme: can this be done by DUMP-PACKAGE?
+(defun note-fast-method-plist (fun ctx)
+ (let ((plist (sb-pcl::method-function-plist fun)))
+ (when plist
+ (%build-fixup (make-fast-method-fixup +fast-method-fixup+ fun plist)
+ ctx))))
+
+(defun dump-code-component (code ctx pos)
+ (let* ((new-address (+ (ctx-base-address ctx) pos))
+ (simple-funs
+ (loop
+ for fun = (sb-kernel:%code-entry-points code)
+ :then (sb-kernel:%simple-fun-next fun)
+ while fun
+ collect fun))
+ (n-header-words (sb-kernel:get-header-data code))
+ (n-code-words (sb-kernel:%code-code-size code))
+ (n-bytes (align (* +n+ (+ n-header-words n-code-words)))))
+ (incf (ctx-position ctx) n-bytes)
+ ;; we register the simple-funs here since they don't dump themselves
+ (sb-sys:with-pinned-objects (code)
+ (let* ((old-address (native-address code))
+ (displacement (- new-address old-address)))
+ (dolist (fun simple-funs)
+ (setf (gethash fun (ctx-addresses ctx))
+ (logior (+ (native-address fun) displacement)
+ sb-vm:fun-pointer-lowtag)))))
+ (lambda ()
+ (sb-sys:with-pinned-objects (code)
+ (let* ((old-address (native-address code))
+ (code-sap (sb-sys:int-sap old-address))
+ (displacement (- new-address old-address))
+ #+x86
+ (old-end-address (+ old-address n-bytes))
+ (data (make-array n-bytes :element-type '(unsigned-byte 8))))
+ ;; grab the whole thing so that fixups will be easier to do
+ (dotimes (i n-bytes)
+ (setf (elt data i) (sb-sys:sap-ref-8 code-sap i)))
+ (labels ((set-word (byte-offset value)
+ (declare (optimize (sb-ext:inhibit-warnings 3)))
+ (unless (integerp value)
+ (push (+ pos byte-offset) (fixup-locations value))
+ (setf value +invalid+))
+ (if #.(eq sb-c::*backend-byte-order* :big-endian)
+ (loop
+ for i from (- sb-vm:n-word-bits 8) downto 0 by 8
+ for j from byte-offset
+ do (setf (elt data j) (ldb (byte 8 i) value)))
+ (loop
+ for i from 0 below sb-vm:n-word-bits by 8
+ for j from byte-offset
+ do (setf (elt data j) (ldb (byte 8 i) value)))))
+ (dump (i)
+ (let ((address
+ (sub-dump-object (object-ref-lispobj code i) ctx)))
+ (set-word (* +n+ i) address))))
+ ;; update all descriptors
+ (loop
+ for i from 1 below n-header-words
+ do (dump i))
+ (dolist (fun simple-funs)
+ (let ((x (truncate (- (native-address fun) old-address) +n+)))
+ #+(or x86 x86-64)
+ ;; SB-VM:SIMPLE-FUN-SELF-SLOT != SB-KERNEL:%SIMPLE-FUN-SELF
+ (set-word (* (1+ x) +n+)
+ (+ (native-address fun)
+ displacement
+ (* sb-vm:simple-fun-code-offset
+ sb-vm:n-word-bytes)))
+ #-(or x86 x86-64)
+ (dump (1+ x))
+ (loop
+ for i from (+ x 2) below (+ x sb-vm:simple-fun-code-offset)
+ do (dump i))))
+ (dolist (ref (gethash code *foreign-fixups*))
+ (%build-fixup (make-foreign-fixup +foreign-fixup+ ref code)
+ ctx))
+ ;; apply fixups
+ #+x86
+ (let ((fixups
+ (sb-kernel:code-header-ref code sb-vm:code-constants-offset)))
+ (cond
+ ((typep fixups '(simple-array sb-vm:word (*)))
+ (loop for fixup across fixups do
+ (let* ((offset (+ fixup (* +n+ n-header-words)))
+ (old-value (sb-sys:sap-ref-word code-sap offset))
+ (new-value
+ (if (<= old-address
+ old-value
+ (1- old-end-address))
+ (+ old-value displacement)
+ (- old-value displacement))))
+ (set-word offset new-value))))
+ (t
+ ;; FIXME: happens quite often, so seems to be "normal" in at
+ ;; least some cases. Should better investigate this though.
+ #+(or)
+ (error "cowardly refusing to dump function without fixup vector")))))
+ ;; fixme: can this be done by DUMP-PACKAGE?
+ (dolist (fun simple-funs)
+ (let ((name (sb-kernel:%simple-fun-name fun)))
+ (when (and (listp name) (eq (car name) 'sb-pcl::fast-method))
+ (note-fast-method-plist fun ctx))))
+ (seek ctx pos)
+ (write-sequence data (ctx-stream ctx)))))))
+
+(defun dump-non-simple-fun (object ctx pos)
+ (let ((len (sb-kernel:get-closure-length object)))
+ (incf (ctx-position ctx) (* (1+ len) +n+))
+ (lambda ()
+ (note-fast-method-plist object ctx)
+ (let ((fun (sub-dump-object (sb-kernel:%closure-fun object) ctx))
+ (slots
+ (loop
+ for i from 2 to len
+ collect (sub-dump-object (object-ref-lispobj object i) ctx))))
+ #+(or x86 x86-64)
+ (cond
+ ((integerp fun)
+ (setf fun
+ (+ (logandc2 fun sb-vm:lowtag-mask)
+ (* sb-vm:simple-fun-code-offset sb-vm:n-word-bytes))))
+ (t
+ ;; oops! fun was replaced by a fixup. will have to set
+ ;; this slot once the fixup has been resolved.
+ (setf fun +invalid+)
+ (%build-fixup (make-fixup +raw-address-fixup+ object) ctx)))
+ (seek ctx pos)
+ (write-word (make-header-word len (sb-kernel:widetag-of object)) ctx)
+ (write-word fun ctx)
+ (dolist (slot slots)
+ (write-word slot ctx))))))
+
+(defun dump-fdefn (object ctx pos)
+ (let ((len (sb-kernel:get-header-data object)))
+ (incf (ctx-position ctx) (* (1+ len) +n+))
+ (lambda ()
+ (let* ((name (sub-dump-object (sb-kernel:fdefn-name object) ctx))
+ (fun (sub-dump-object (sb-kernel:fdefn-fun object) ctx))
+ (raw-addr #-sparc (object-ref-word object 3)
+ ;; fixme: is the sparc case right?
+ #+sparc fun))
+ #-sparc
+ (when
+ ;; update raw-addr only if it pointed to fun's raw-addr already,
+ ;; because non-simple funs have `closure_tramp' in this slot instead.
+ (eql raw-addr
+ (+ (native-address (sb-kernel:fdefn-fun object))
+ (* sb-vm:simple-fun-code-offset sb-vm:n-word-bytes)))
+ (cond
+ ((integerp fun)
+ (setf raw-addr
+ (+ (logandc2 fun sb-vm:lowtag-mask)
+ (* sb-vm:simple-fun-code-offset sb-vm:n-word-bytes))))
+ (t
+ ;; oops! fun was replaced by a fixup. will have to set
+ ;; this slot once the fixup has been resolved.
+ (setf raw-addr +invalid+)
+ (%build-fixup (make-fixup +raw-address-fixup+ object) ctx))))
+ (seek ctx pos)
+ (write-word (make-header-word len (sb-kernel:widetag-of object)) ctx)
+ (write-word name ctx)
+ (write-word fun ctx)
+ (write-word raw-addr ctx)))))
Added: trunk/sb-heapdump/generation.h
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/generation.h Sun May 21 14:31:55 2006
@@ -0,0 +1,55 @@
+/* -*- indent-tabs-mode: nil -*- */
+/* this isn't in gencgc-internal.h, so we need to copy&paste it */
+
+enum {
+ HIGHEST_NORMAL_GENERATION = 5,
+ PSEUDO_STATIC_GENERATION,
+ SCRATCH_GENERATION,
+ NUM_GENERATIONS
+};
+
+struct generation {
+
+ /* the first page that gc_alloc() checks on its next call */
+ page_index_t alloc_start_page;
+
+ /* the first page that gc_alloc_unboxed() checks on its next call */
+ page_index_t alloc_unboxed_start_page;
+
+ /* the first page that gc_alloc_large (boxed) considers on its next
+ * call. (Although it always allocates after the boxed_region.) */
+ page_index_t alloc_large_start_page;
+
+ /* the first page that gc_alloc_large (unboxed) considers on its
+ * next call. (Although it always allocates after the
+ * current_unboxed_region.) */
+ page_index_t alloc_large_unboxed_start_page;
+
+ /* the bytes allocated to this generation */
+ long bytes_allocated;
+
+ /* the number of bytes at which to trigger a GC */
+ long gc_trigger;
+
+ /* to calculate a new level for gc_trigger */
+ long bytes_consed_between_gc;
+
+ /* the number of GCs since the last raise */
+ int num_gc;
+
+ /* the average age after which a GC will raise objects to the
+ * next generation */
+ int trigger_age;
+
+ /* the cumulative sum of the bytes allocated to this generation. It is
+ * cleared after a GC on this generations, and update before new
+ * objects are added from a GC of a younger generation. Dividing by
+ * the bytes_allocated will give the average age of the memory in
+ * this generation since its last GC. */
+ long cum_sum_bytes_allocated;
+
+ /* a minimum average memory age before a GC will occur helps
+ * prevent a GC when a large number of new live objects have been
+ * added, in which case a GC could be a waste of time */
+ double min_av_mem_age;
+};
Added: trunk/sb-heapdump/load.lisp
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/load.lisp Sun May 21 14:31:55 2006
@@ -0,0 +1,230 @@
+;;; -*- indent-tabs-mode: nil -*-
+
+;;; Copyright (c) 2006 David Lichteblau
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation files
+;;; (the "Software"), to deal in the Software without restriction,
+;;; including without limitation the rights to use, copy, modify, merge,
+;;; publish, distribute, sublicense, and/or sell copies of the Software,
+;;; and to permit persons to whom the Software is furnished to do so,
+;;; subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;;; SOFTWARE.
+
+(in-package :sb-heapdump)
+
+(defvar *dumpload-verbose* t)
+
+(defmacro with-timing ((&optional) &body body)
+ `(invoke-with-timing (lambda () , at body)))
+
+(sb-alien:define-alien-routine "map_dumpfile" sb-alien:unsigned-long
+ (fd sb-alien:int)
+ (offset sb-alien:unsigned-long)
+ (verbose sb-alien:int))
+
+(defun load-dumpfile (pathname &key customizer suppress-initializer start end)
+ (with-open-file (s pathname :element-type :default :external-format :utf8)
+ (let ((file-length (or end (file-length s)))
+ (offset (or start 0)))
+ (loop
+ (when *dumpload-verbose*
+ (format t "~&; loading ~A[~X]" pathname offset)
+ (force-output))
+ (multiple-value-bind (header length)
+ (sub-load-dumpfile s customizer offset)
+ (incf offset length)
+ (if (< offset file-length)
+ (initialize header suppress-initializer)
+ (return (initialize header suppress-initializer))))))))
+
+(defun initialize (header suppress-initializer)
+ (multiple-value-prog1
+ (cond
+ ((and (header-initializer header)
+ (not suppress-initializer))
+ (write-string! " init")
+ (with-timing ()
+ (funcall (car (header-initializer header))
+ (header-object header))))
+ (t
+ (values (header-object header)
+ (car (header-initializer header)))))
+ (when *dumpload-verbose*
+ (format t " done~%"))))
+
+(defun sub-load-dumpfile (s customizer offset)
+ ;; kludge: holding *already-in-gc* means losing *gc-pending* if some
+ ;; other thread wants to do GC in the (unlikely?) event of a race with
+ ;; us. However, using sb-sys:without-gcing instead of acquiring
+ ;; sb-kernel::*already-in-gc* doesn't work, it deadlocks somehow.
+ (sb-thread:with-mutex (sb-kernel::*already-in-gc*)
+ (sb-sys:without-interrupts
+ (write-string! " mmap")
+ (sb-kernel::gc-stop-the-world)
+ (unwind-protect
+ (let* ((verbose (if *dumpload-verbose* 1 0))
+ (base-sap
+ (with-timing ()
+ (sb-sys:int-sap
+ (map-dumpfile (sb-sys:fd-stream-fd s) offset verbose))))
+ (length (sb-sys:sap-ref-word base-sap +n+))
+ (header
+ (sb-kernel:make-lisp-obj (sb-sys:sap-ref-word base-sap +2n+)))
+ (bla (cons header nil)))
+ (write-string! " fixup")
+ (with-timing ()
+ (sb-ext:with-unlocked-packages (:sb-pcl)
+ (handler-bind ((style-warning #'muffle-warning))
+ (apply-fixups base-sap
+ (header-fixups header)
+ (or customizer
+ (car (header-customizer header)))))))
+ (values header length bla))
+ (sb-kernel::gc-start-the-world)))))
+
+(defun write-string! (str)
+ (when *dumpload-verbose*
+ (write-string str)
+ (force-output)))
+
+(defun invoke-with-timing (fn)
+ (if *dumpload-verbose*
+ (let ((a (get-internal-real-time)))
+ (multiple-value-prog1
+ (funcall fn)
+ (let ((b (get-internal-real-time)))
+ (format t " ~Fs"
+ (float (/ (- b a) internal-time-units-per-second)
+ 1.0s0)))))
+ (funcall fn)))
+
+(locally
+ (declare (optimize speed (safety 0) (debug 0) (space 0)))
+ (defun apply-fixups (base-sap fixups customizer)
+ (dolist (f fixups)
+ (let ((value
+ (sb-kernel:get-lisp-obj-address (resolve-fixup f customizer)))
+ (locations (fixup-locations f)))
+ (declare (type (simple-array (unsigned-byte #.sb-vm:n-word-bits) (*))
+ locations))
+ (loop
+ for location of-type (unsigned-byte #.sb-vm:n-positive-fixnum-bits)
+ across locations
+ do (setf (sb-sys:sap-ref-word base-sap location) value))))))
+
+(defun resolve-fixup (f customizer)
+ (ecase (fixup-type f)
+ (#.+package-fixup+
+ (let ((name (fixup-id f)))
+ (or (find-package name)
+ (error "referenced package ~S not present" name))))
+ (#.+symbol-fixup+
+ (intern (fixup-id f) (fixup-id2 f)))
+ (#.+classoid-fixup+
+ (sb-kernel:find-classoid (fixup-id f)))
+ (#.+layout-fixup+
+ (sb-kernel:classoid-layout (fixup-id f)))
+ (#.+fdefn-fixup+
+ (let* ((name (fixup-id f)))
+ (or (sb-int:info :function :definition name)
+ (error "referenced function ~S not present" name))))
+ (#.+named-type-fixup+
+ (let ((result (sb-kernel:values-specifier-type (fixup-id f))))
+ (check-type result sb-kernel:named-type)
+ result))
+ (#.+array-type-fixup+
+ (apply #'sb-kernel:make-array-type (fixup-id f)))
+ (#.+class-fixup+
+ (find-class (fixup-id f)))
+ (#.+function-fixup+
+ (fdefinition (fixup-id f)))
+ (#.+ctor-fixup+
+ (destructuring-bind (fn class &rest initargs)
+ (fixup-id f)
+ (sb-pcl::ensure-ctor fn class initargs)
+ (fdefinition fn)))
+ (#.+slot-accessor-fixup+
+ (let ((x (fixup-id f)))
+ (sb-pcl::ensure-accessor (fourth x) x (third x))
+ (fdefinition x)))
+ (#.+fast-method-fixup+
+ (setf (sb-pcl::method-function-plist (fixup-id f))
+ (fixup-id2 f))
+ nil)
+ (#.+raw-address-fixup+
+ (let ((object (fixup-id f)))
+ (if (functionp object)
+ (let* ((new-fun
+ (sb-kernel:get-lisp-obj-address
+ (sb-kernel:%closure-fun object))))
+ (setf (object-ref-word object 1)
+ (+ (logandc2 new-fun sb-vm:lowtag-mask)
+ (* sb-vm:simple-fun-code-offset
+ sb-vm:n-word-bytes))))
+ (let* ((new-fun
+ (sb-kernel:get-lisp-obj-address
+ (sb-kernel:fdefn-fun object))))
+ (setf (object-ref-word object 3)
+ (+ (logandc2 new-fun sb-vm:lowtag-mask)
+ (* sb-vm:simple-fun-code-offset
+ sb-vm:n-word-bytes)))))))
+ (#.+variable-fixup+
+ (symbol-value (fixup-id f)))
+ (#.+foreign-fixup+
+ (let* ((ref (fixup-id f))
+ (code (fixup-id2 f))
+ (address
+ (sb-sys:foreign-symbol-address
+ (foreign-ref-symbol ref)
+ (foreign-ref-datap ref))))
+ (push ref (gethash code *foreign-fixups*))
+ #+(or x86 x86-64)
+ (let* ((sap (native-pointer code))
+ (n-header-words (sb-kernel:get-header-data code))
+ (pos (+ (foreign-ref-offset ref) (* +n+ n-header-words))))
+ ;; -32, because these are :absolute fixups, not :absolute64
+ (setf (sb-sys:sap-ref-32 sap pos) address))
+ #+ppc
+ (sb-vm::fixup-code-object code
+ (foreign-ref-offset ref)
+ address
+ (foreign-ref-kind ref))))
+ (#.+user-fixup+
+ (funcall customizer (fixup-id f) (fixup-id2 f)))))
+
+(sb-alien:define-alien-routine ("relocate_dumpfile" relocate_dumpfile)
+ sb-alien:unsigned-long
+ (fd sb-alien:int)
+ (offset sb-alien:long)
+ (base sb-alien:unsigned-long))
+
+(defun relocate-dumpfiles
+ (pathnames &optional (base-address *default-base-address*))
+ (dolist (pathname pathnames)
+ (incf base-address (relocate-dumpfile pathname base-address))))
+
+(defun relocate-dumpfile
+ (pathname &optional (base-address *default-base-address*))
+ (with-open-file (s pathname :direction :io :if-exists :overwrite)
+ (let ((fd (sb-sys:fd-stream-fd s))
+ (file-length (file-length s))
+ (offset 0))
+ (loop while (< offset file-length) do
+ (format t "~&relocating ~A[~X] to ~8,'0X~%"
+ pathname offset base-address)
+ (let ((length (relocate_dumpfile fd offset base-address)))
+ (incf base-address length)
+ (incf offset length)))
+ file-length)))
Added: trunk/sb-heapdump/module.lisp
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/module.lisp Sun May 21 14:31:55 2006
@@ -0,0 +1,96 @@
+;;; -*- indent-tabs-mode: nil -*-
+
+;;; Copyright (c) 2006 David Lichteblau
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation files
+;;; (the "Software"), to deal in the Software without restriction,
+;;; including without limitation the rights to use, copy, modify, merge,
+;;; publish, distribute, sublicense, and/or sell copies of the Software,
+;;; and to permit persons to whom the Software is furnished to do so,
+;;; subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;;; SOFTWARE.
+
+(in-package :sb-heapdump)
+
+(defvar *central-registry*
+ (list *default-pathname-defaults*
+ (truename (sb-ext:posix-getenv "SBCL_HOME"))))
+
+(defun dump-systems (pathname systems package-names &key (if-exists :error))
+ (let* ((names (mapcar #'asdf::coerce-name systems))
+ (specs
+ (mapcar (lambda (name)
+ (or (gethash name asdf::*defined-systems*)
+ (error "system not found: ~A" name)))
+ names))
+ (depends-on
+ (loop
+ for (nil . system) in specs
+ for do-first = (slot-value system 'asdf::do-first)
+ for in-order-to-compile = (cdr (assoc 'asdf:compile-op do-first))
+ append (cdr (assoc 'asdf:load-op in-order-to-compile)))))
+ (setf depends-on (mapcar #'asdf::coerce-name depends-on))
+ (setf depends-on (remove-duplicates depends-on :test #'string=))
+ (setf depends-on (set-difference depends-on names :test #'string=))
+ (dump-packages
+ package-names
+ pathname
+ :initializer (lambda (packages)
+ (dolist (spec specs)
+ (let ((name (asdf:component-name (cdr spec))))
+ (setf (gethash name asdf::*defined-systems*) spec)))
+ (dolist (dep depends-on)
+ (unless (find (string-upcase dep) *modules* :test 'equal)
+ (when *dumpload-verbose*
+ (format t "~&; loading dependency ~A~%" dep))
+ (require dep)))
+ packages)
+ :if-exists if-exists)))
+
+(defmethod dump-system ((system symbol))
+ (dump-system (asdf:find-system system)))
+
+(defmethod dump-system ((system string))
+ (dump-system (asdf:find-system system)))
+
+(defmethod dump-system ((c asdf:component))
+ (error "Component ~A does not implement SB-HEAPDUMP:DUMP-SYSTEM." c))
+
+(defun coerce-name (name)
+ (etypecase name
+ (symbol (string-downcase (symbol-name name)))
+ (string name)))
+
+(defun find-heap-file (name)
+ (some (lambda (dir)
+ (let* ((defaults (eval dir))
+ (file (and defaults
+ (make-pathname
+ :defaults defaults :version :newest
+ :name name :type "heap" :case :local))))
+ (and file (probe-file file))))
+ *central-registry*))
+
+(defun module-provide-heapfile (name)
+ (setf name (coerce-name name))
+ (if (gethash name asdf::*defined-systems*)
+ nil
+ (let ((heap-file (find-heap-file name)))
+ (when heap-file
+ (load-dumpfile heap-file)
+ (provide (string-upcase name))
+ t))))
+
+(pushnew 'module-provide-heapfile sb-ext:*module-provider-functions*)
Added: trunk/sb-heapdump/pack.lisp
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/pack.lisp Sun May 21 14:31:55 2006
@@ -0,0 +1,221 @@
+;;; -*- indent-tabs-mode: nil -*-
+
+;;; Copyright (c) 2006 David Lichteblau
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation files
+;;; (the "Software"), to deal in the Software without restriction,
+;;; including without limitation the rights to use, copy, modify, merge,
+;;; publish, distribute, sublicense, and/or sell copies of the Software,
+;;; and to permit persons to whom the Software is furnished to do so,
+;;; subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;;; SOFTWARE.
+
+(in-package :sb-heapdump)
+
+(defstruct (package-data
+ (:type vector)
+ (:conc-name "PD-")
+ (:constructor make-package-data (packages)))
+ packages
+ (infos nil)
+ (find-class-cells nil)
+ (methods (make-hash-table))
+ (fast-methods nil))
+
+(defun dump-packages
+ (packages pathname
+ &rest keys
+ &key if-exists parameters print-statistics initializer force
+ customizer load-time-customizer base-address
+ force-specializers systems system-packages)
+ (declare (ignore parameters print-statistics customizer load-time-customizer
+ base-address))
+ (unless (listp packages)
+ (setf packages (list packages)))
+ (setf packages
+ (mapcar (lambda (p)
+ (or (find-package p) (error "package not found: ~A" p)))
+ packages))
+ (unless initializer
+ (setf initializer #'identity))
+ (when (or systems system-packages)
+ (dump-systems pathname systems system-packages :if-exists if-exists)
+ (setf if-exists :append))
+ (let ((pd (collect-package-data packages force)))
+ (dolist (x force-specializers)
+ (collect-method-data! pd x))
+ (apply #'dump-object
+ (or packages "dummy")
+ pathname
+ :force (append packages force)
+ :initializer (if packages
+ (lambda (new-packages)
+ (reinstall-package-data pd new-packages)
+ (funcall initializer new-packages))
+ initializer)
+ :if-exists if-exists
+ :allow-other-keys t
+ keys)))
+
+(defun reinstall-package-data (pd new-packages)
+ (dolist (package new-packages)
+ (sb-impl::enter-new-nicknames
+ package
+ (cons (package-name package) (package-nicknames package))))
+ (loop for (sym class . plist) in (pd-infos pd) do
+ (loop for (type def) on plist by #'cddr do
+ (setf (sb-int:info class type sym) def)))
+ (loop for (sym cell) on (pd-find-class-cells pd) by #'cddr do
+ (setf (gethash sym sb-pcl::*find-class*) cell))
+ (maphash (lambda (gf ms)
+ (dolist (m ms)
+ (setf (sb-mop:method-generic-function m) nil)
+ (sb-pcl::real-add-method gf m t))
+ (sb-pcl::update-dfun gf))
+ (pd-methods pd)))
+
+(defun collect-package-data (packages force)
+ (let ((pd (make-package-data packages)))
+ (dolist (package packages)
+ (do-symbols (sym package)
+ (when (eq (symbol-package sym) package)
+ (collect-symbol-data! pd sym))))
+ (dolist (x force)
+ (when (symbolp force)
+ (collect-symbol-data! pd x)))
+ pd))
+
+(defun collect-symbol-data! (pd sym)
+ (nconc-infos pd (infos sym))
+ (nconc-infos pd (infos `(setf ,sym) :function))
+ (let ((cell (gethash sym sb-pcl::*find-class*)))
+ (when cell
+ (push cell (pd-find-class-cells pd))
+ (push sym (pd-find-class-cells pd))
+ (let ((class (sb-pcl::find-class-cell-class cell)))
+ (when class
+ (collect-slot-data! pd class)
+ (collect-method-data! pd class))))))
+
+(defun nconc-infos (pd infos)
+ (setf (pd-infos pd) (nconc infos (pd-infos pd))))
+
+(defun collect-slot-data! (pd class)
+ (dolist (slot (sb-mop:class-slots class))
+ (dolist (rwb '(sb-pcl::reader
+ sb-pcl::writer
+ sb-pcl::boundp))
+ (nconc-infos pd (infos `(sb-pcl::slot-accessor
+ :global
+ ,(sb-mop:slot-definition-name slot)
+ ,rwb)
+ :function)))))
+
+(defun collect-method-data! (pd class)
+ (dolist (method (sb-mop:specializer-direct-methods class))
+ (let* ((gf (sb-mop:method-generic-function method))
+ (id (function-name-identifier
+ (sb-mop:generic-function-name gf))))
+ ;; fixme: ist das folgende auch noetig fuer:
+ ;; (slot-value method 'sb-pcl::function)
+ (let ((fm (sb-pcl::method-fast-function method)))
+ (when fm
+ (when
+ ;; FIXME!
+ (eq (car (sb-kernel:%fun-name fm)) 'sb-pcl::fast-method)
+ (push fm (pd-fast-methods pd))
+ (nconc-infos pd (infos (sb-kernel:%fun-name fm) :function)))))
+ (unless (and id (member (symbol-package id) (pd-packages pd)))
+ (push method (gethash gf (pd-methods pd)))))))
+
+(defun infos (name &optional class)
+ (let ((result '()))
+ (maphash (lambda (c class-info)
+ (when (or (null class) (eq c class))
+ (let ((types (sb-c::class-info-types class-info)))
+ (let ((plist
+ (loop
+ for type-info in types
+ for type = (sb-c::type-info-name type-info)
+ for (def hit)
+ := (multiple-value-list
+ (handler-case
+ (sb-int:info c type name)
+ ;; KLUDGE: there doesn't seem to be a
+ ;; way to suppress default values, and
+ ;; some of them throw errors.
+ (sb-int:bug ()
+ nil)))
+ when hit
+ append (list type def))))
+ (when plist
+ (push (list* name c plist) result))))))
+ sb-c::*info-classes*)
+ result))
+
+(defun make-executable
+ (heapfile
+ &key (output-pathname (make-pathname :type nil :defaults heapfile))
+ main-function
+ (if-exists :error))
+ (with-open-file (in heapfile :element-type '(unsigned-byte 8))
+ (with-open-file (trampoline
+ (make-pathname :name "trampoline"
+ :type nil
+ :defaults
+ (asdf:component-relative-pathname
+ (asdf:find-system :sb-heapdump)))
+ :element-type '(unsigned-byte 8))
+ (with-open-file
+ (out output-pathname
+ :direction :output
+ :element-type '(unsigned-byte 8)
+ ;; KLUDGE! See DUMP-OBJECT.
+ :if-exists (if (eq if-exists :append) :overwrite if-exists))
+ (when (eq if-exists :append)
+ (file-position out (file-length out)))
+ (copy-stream trampoline out)
+ (let* ((length (file-length out))
+ (padding
+ (- (nth-value 1 (ceiling length +page-size+)))))
+ (dotimes (x padding)
+ (write-byte 0 out))
+ (copy-stream in out)
+ (force-output out)
+ (when main-function
+ (dump-object (list :dummy)
+ out
+ :initializer (lambda (x)
+ (declare (ignore x))
+ (apply main-function
+ (cdr sb-ext:*posix-argv*)))
+ :if-exists :append))
+ (file-position out (file-length out))
+ (%write-word (+ length padding) out))))))
+
+;; copy-stream taken from SBCL source code
+;; contrib/sb-executable/sb-executable.lisp
+(defvar *stream-buffer-size* 8192)
+(defun copy-stream (from to)
+ "Copy into TO from FROM until end of the input stream, in blocks of
+*stream-buffer-size*. The streams should have the same element type."
+ (unless (subtypep (stream-element-type to) (stream-element-type from))
+ (error "Incompatible streams ~A and ~A." from to))
+ (let ((buf (make-array *stream-buffer-size*
+ :element-type (stream-element-type from))))
+ (loop
+ (let ((pos (read-sequence buf from)))
+ (when (zerop pos) (return))
+ (write-sequence buf to :end pos)))))
Added: trunk/sb-heapdump/package.lisp
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/package.lisp Sun May 21 14:31:55 2006
@@ -0,0 +1,29 @@
+;;; -*- indent-tabs-mode: nil -*-
+
+(in-package :cl-user)
+
+(defpackage :sb-heapdump
+ (:use :cl)
+ (:shadow #:defun #:lambda)
+ (:export #:*dumpload-verbose* #:*dump-verbose* #:*central-registry*
+ #:dump-object #:dump-packages #:dump-system
+ #:load-dumpfile
+ #:relocate-dumpfile #:relocate-dumpfiles
+ #:make-executable))
+
+(in-package :sb-heapdump)
+
+;; Give lambdas a name, since SBCL prints them only as ((LAMBDA ())) in
+;; backtraces otherwise, and that's not good enough with the large number
+;; of functions we have that use the lambda trick.
+(defmacro defun (name (&rest args) &body body)
+ (let ((declarationp (and (listp (car body)) (eq (caar body) 'declare))))
+ `(cl:defun ,name ,args
+ ,@(when declarationp
+ (list (car body)))
+ (macrolet ((lambda ((&rest args) &body body)
+ `(sb-int:named-lambda ,'(lambda ,name) ,args , at body)))
+ ,@(if declarationp (cdr body) body)))))
+
+(defmacro lambda ((&rest args) &body body)
+ `(cl:lambda ,args , at body))
Added: trunk/sb-heapdump/patch.lisp
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/patch.lisp Sun May 21 14:31:55 2006
@@ -0,0 +1,89 @@
+;;; -*- indent-tabs-mode: nil -*-
+
+;;; Copyright (c) 2006 David Lichteblau
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation files
+;;; (the "Software"), to deal in the Software without restriction,
+;;; including without limitation the rights to use, copy, modify, merge,
+;;; publish, distribute, sublicense, and/or sell copies of the Software,
+;;; and to permit persons to whom the Software is furnished to do so,
+;;; subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;;; SOFTWARE.
+
+(in-package :sb-heapdump)
+
+(defvar *foreign-fixups* (make-hash-table)) ;fixme: should be weak
+
+(defstruct (foreign-ref
+ (:constructor make-foreign-ref (offset kind symbol datap)))
+ offset
+ kind
+ symbol
+ datap)
+
+(sb-ext:with-unlocked-packages (:sb-fasl)
+ (macrolet
+ ((doit (datap)
+ `(let* ((kind (sb-fasl::pop-stack))
+ (code-object (sb-fasl::pop-stack))
+ (len (sb-fasl::read-byte-arg))
+ (sym (make-string len :element-type 'base-char)))
+ (sb-sys:read-n-bytes sb-fasl::*fasl-input-stream* sym 0 len)
+ (let* ((offset (sb-fasl::read-word-arg))
+ #-ppc
+ (oldval
+ (sb-sys:without-gcing
+ (sb-sys:sap-ref-32
+ (sb-kernel:code-instructions code-object)
+ offset))))
+ (sb-vm:fixup-code-object code-object
+ offset
+ (sb-sys:foreign-symbol-address sym)
+ kind)
+ (let ((fixups
+ (sb-kernel:code-header-ref
+ code-object
+ sb-vm:code-constants-offset)))
+ (unless (and (vectorp fixups) (find offset fixups))
+ #-ppc (assert (eq kind :absolute))
+ #-ppc (assert (zerop oldval))
+ (push (make-foreign-ref offset kind sym ,datap)
+ (gethash code-object *foreign-fixups*)))))
+ code-object)))
+ (sb-fasl::define-fop (sb-fasl::fop-foreign-fixup 147) (doit nil))
+ #+linkage-table
+ (sb-fasl::define-fop (sb-fasl::fop-foreign-dataref-fixup 150) (doit t))))
+
+(defvar *do-core-fixups* #'sb-c::do-core-fixups)
+
+(sb-ext:with-unlocked-packages (:sb-c)
+ (defun sb-c::do-core-fixups (code fixup-notes)
+ (dolist (note fixup-notes)
+ (let* ((kind (sb-c::fixup-note-kind note))
+ (fixup (sb-c::fixup-note-fixup note))
+ (offset (sb-c::fixup-note-position note))
+ (sym (sb-c::fixup-name fixup))
+ (flavor (sb-c::fixup-flavor fixup)))
+ (funcall *do-core-fixups* code (list note))
+ (when (or (eq flavor :foreign) (eq flavor :foreign-dataref))
+ (let ((fixups
+ (sb-kernel:code-header-ref
+ code
+ sb-vm:code-constants-offset))
+ (datap (eq flavor :foreign-dataref)))
+ (unless (and (vectorp fixups) (find offset fixups))
+ #-ppc (assert (eq kind :absolute))
+ (push (make-foreign-ref offset kind sym datap)
+ (gethash code *foreign-fixups*)))))))))
Added: trunk/sb-heapdump/relocate.c
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/relocate.c Sun May 21 14:31:55 2006
@@ -0,0 +1,633 @@
+/* -*- indent-tabs-mode: nil -*- */
+
+/* Copyright (c) 2006 David Lichteblau
+ * partly derived from SBCL source code (gc-common.c/gencgc.c)
+ *
+ * Tested on x86, x86-64, and PPC.
+ *
+ * When using this code to relocate memory not dumped by sb-heapdump,
+ * read the note in relocate_simple_vector.
+ */
+/*
+ * Permission is hereby granted, free of charge, to any person
+ * obtaining a copy of this software and associated documentation files
+ * (the "Software"), to deal in the Software without restriction,
+ * including without limitation the rights to use, copy, modify, merge,
+ * publish, distribute, sublicense, and/or sell copies of the Software,
+ * and to permit persons to whom the Software is furnished to do so,
+ * subject to the following conditions:
+ *
+ * The above copyright notice and this permission notice shall be
+ * included in all copies or substantial portions of the Software.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ * NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+ * BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+ * ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+ * CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+ * SOFTWARE.
+ */
+#include <unistd.h>
+#include <stdio.h>
+#include <errno.h>
+#include "genesis/config.h"
+#include "validate.h"
+#include "gc.h"
+#ifdef LISP_FEATURE_GENCGC
+#include "gencgc-internal.h"
+#else
+#include "cheneygc-internal.h"
+#endif
+#include "gc-internal.h"
+#include "generation.h"
+#include "runtime.h"
+#include "interr.h"
+#include "genesis/fdefn.h"
+#include "genesis/closure.h"
+#include "genesis/instance.h"
+#include "genesis/layout.h"
+#include "genesis/code.h"
+#include "genesis/simple-fun.h"
+#include "genesis/vector.h"
+
+/*
+ * stuff from src/runtime not declared in the official headers
+ */
+#ifdef LISP_FEATURE_GENCGC
+extern unsigned long bytes_allocated;
+extern struct generation generations[NUM_GENERATIONS];
+extern long large_object_size;
+page_index_t gc_find_freeish_pages(long *, long, int);
+#endif
+
+/*
+ * our stuff
+ */
+#define ALIGN(len) CEILING(len, 2)
+#define RELOCATE_BOXED 0
+#define RELOCATE_IMMEDIATE 0
+
+#ifndef LISP_FEATURE_GENCGC
+#define PAGE_BYTES 0x1000
+#endif
+
+struct relocator {
+ long *start;
+ long *end;
+ long displacement;
+ void *baseptr;
+};
+
+typedef long (*relocfn)(long *, struct relocator *);
+static relocfn reloctab[256];
+
+static int reloctab_initialized = 0;
+
+static void relocate_init();
+static void relocate(long *, long nwords, long *old_start, long displacement);
+static void sub_relocate(long *ptr, long nwords, struct relocator *ctx);
+
+
+/*
+ * heap file mapping
+ */
+#ifdef LISP_FEATURE_GENCGC
+static void
+find_free_pages(long *start_page, long *end_page, long nbytes)
+{
+ long los = large_object_size;
+
+ large_object_size = 0;
+ *end_page = 1 + gc_find_freeish_pages(start_page, nbytes, 0);
+ large_object_size = los;
+}
+
+#define GEN 2
+
+void *
+map_dumpfile(int fd, long offset, int verbose)
+{
+ unsigned long length;
+ void *base = 0;
+ void *old_base;
+ long start_page, end_page;
+ long npages;
+ long i;
+
+ if (!reloctab_initialized) {
+ relocate_init();
+ reloctab_initialized = 1;
+ }
+
+ if (lseek(fd, offset, SEEK_SET) == -1) {
+ perror("lseek");
+ lose("map_dumpfile: cannot seek to segment");
+ }
+ if (read(fd, &old_base, sizeof(long)) != sizeof(long)
+ || read(fd, &length, sizeof(long)) != sizeof(long))
+ {
+ perror("read");
+ lose("map_dumpfile: cannot read header");
+ }
+ npages = (length + PAGE_BYTES - 1) / PAGE_BYTES;
+
+ if ( (start_page = find_page_index(old_base)) != -1) {
+ end_page = start_page + npages;
+ for (i = start_page; i < end_page; i++)
+ if (page_table[i].allocated != FREE_PAGE_FLAG)
+ break;
+ if (i == end_page)
+ base = old_base;
+ }
+ if (!base) {
+ find_free_pages(&start_page, &end_page, length);
+ base = page_address(start_page);
+ if (verbose) {
+ printf("\n; relocating heap file from 0x%08lx"
+ " to 0x%08lx\n",
+ (long) old_base,
+ (long) base);
+ fflush(stdout);
+ }
+ }
+
+ if (base != mmap(base,
+ length,
+ PROT_READ | PROT_WRITE,
+ MAP_FIXED | MAP_PRIVATE,
+ fd,
+ offset))
+ {
+ perror("mmap");
+ lose("map_dumpfile: cannot mmap heap file");
+ }
+ if (base != old_base)
+ relocate(base, length/N_WORD_BYTES, old_base, base-old_base);
+
+ os_protect(base,
+ npages * PAGE_BYTES,
+#ifdef WRITE_PROTECT
+ OS_VM_PROT_READ | OS_VM_PROT_EXECUTE
+#else
+ OS_VM_PROT_ALL | OS_VM_PROT_EXECUTE
+#endif
+ );
+
+ for (i = 0; i < npages; i++) {
+ long page = start_page + i;
+ page_table[page].allocated = BOXED_PAGE_FLAG;
+ page_table[page].gen = GEN;
+ page_table[page].large_object = 0;
+ page_table[page].first_object_offset = -(PAGE_BYTES * i);
+ page_table[page].bytes_used = PAGE_BYTES;
+#ifdef WRITE_PROTECT
+ page_table[page].write_protected = 1;
+#else
+ page_table[page].write_protected = 0;
+#endif
+ page_table[page].write_protected_cleared = 0;
+ page_table[page].dont_move = 0;
+ }
+ page_table[end_page - 1].bytes_used = length - PAGE_BYTES * (npages-1);
+ generations[GEN].bytes_allocated += length;
+#if 0
+ /* fixme: do we need these? */
+ bytes_allocated += length;
+ generations[GEN].cum_sum_bytes_allocated += length;
+#endif
+
+ if (last_free_page < end_page)
+ last_free_page = end_page;
+ SetSymbolValue(ALLOCATION_POINTER,
+ (lispobj)(((char *)DYNAMIC_SPACE_START)
+ + last_free_page*PAGE_BYTES),
+ 0);
+
+ return base;
+}
+#else
+void *
+map_dumpfile(int fd, long offset, int verbose)
+{
+ unsigned long length;
+ void *base;
+ void *old_base;
+
+ if (!reloctab_initialized) {
+ relocate_init();
+ reloctab_initialized = 1;
+ }
+
+ if (lseek(fd, offset, SEEK_SET) == -1) {
+ perror("lseek");
+ lose("map_dumpfile: cannot seek to segment");
+ }
+ if (read(fd, &old_base, sizeof(long)) != sizeof(long)
+ || read(fd, &length, sizeof(long)) != sizeof(long))
+ {
+ perror("read");
+ lose("map_dumpfile: cannot read header");
+ }
+
+ base = (void *) CEILING((long)dynamic_space_free_pointer, PAGE_BYTES);
+ dynamic_space_free_pointer = base + length;
+
+ if (base != mmap(base,
+ length,
+ PROT_READ | PROT_WRITE,
+ MAP_FIXED | MAP_PRIVATE,
+ fd,
+ offset))
+ {
+ perror("mmap");
+ lose("map_dumpfile: cannot mmap heap file");
+ }
+ if (verbose) {
+ printf("\n; relocating heap file from 0x%08lx to 0x%08lx\n",
+ (long) old_base,
+ (long) base);
+ fflush(stdout);
+ }
+ relocate(base, length/N_WORD_BYTES, old_base, base-old_base);
+
+ os_flush_icache((os_vm_address_t) base, length);
+
+ return base;
+}
+#endif
+
+long
+relocate_dumpfile(int fd, long offset, long *new_base)
+{
+ long length;
+ void *tmp;
+ long *old_base;
+ long displacement;
+
+ if (!reloctab_initialized) {
+ relocate_init();
+ reloctab_initialized = 1;
+ }
+
+ if (lseek(fd, offset, SEEK_SET) == -1) {
+ perror("lseek");
+ lose("map_dumpfile: cannot seek to segment");
+ }
+ if (read(fd, &old_base, sizeof(long)) != sizeof(long)
+ || read(fd, &length, sizeof(long)) != sizeof(long))
+ {
+ perror("read");
+ lose("relocate_dumpfile: cannot read header");
+ }
+
+ tmp = mmap(0, length, PROT_READ | PROT_WRITE, MAP_SHARED, fd, offset);
+ if (tmp == MAP_FAILED) {
+ perror("mmap");
+ lose("relocate_dumpfile: cannot map heap file");
+ }
+#ifdef LISP_FEATURE_GENCGC
+ if ((long) tmp % PAGE_BYTES != 0)
+ lose("relocate_dumpfile: bad base address");
+#endif
+
+ displacement = (void *) new_base - (void *) old_base;
+ relocate(tmp, length/N_WORD_BYTES, old_base, displacement);
+ *((long **) tmp) = new_base;
+
+ if (munmap(tmp, length) == -1) {
+ perror("munmap");
+ lose("relocate_dumpfile: cannot unmap heap file");
+ }
+ return length;
+}
+
+
+/*
+ * relocation
+ */
+static void *
+natify(lispobj thing, struct relocator *ctx)
+{
+ /* Same as `native_pointer' if tempspace == newspace. Else,
+ * turn the result into a tempspace pointer.
+ * This is for relocate_dumpfile. */
+ void *old_start = (void *) ctx->start;
+ void *new_start = old_start + ctx->displacement;
+ void *ptr = native_pointer((long) thing);
+ long offset = ptr - new_start;
+ return (void *) ctx->baseptr + offset;
+}
+
+#ifdef LISP_FEATURE_X86
+static void *
+oldify(void *ptr, struct relocator *ctx)
+{
+ return (void *) ctx->start + (ptr - (void *) ctx->baseptr);
+}
+#endif
+
+static void
+relocate(long *ptr, long nwords, long *old_start, long displacement)
+{
+ struct relocator ctx;
+
+ ctx.baseptr = ptr;
+ ctx.start = old_start;
+ ctx.end = old_start + nwords;
+ ctx.displacement = displacement;
+
+ sub_relocate(ptr, nwords, &ctx);
+}
+
+static void
+sub_relocate(long *ptr, long nwords, struct relocator *ctx)
+{
+ long *p;
+ long *q = ptr + nwords;
+ long nrelocated;
+
+ for (p = ptr; p < q; p += nrelocated) {
+ long word = *p;
+ if (is_lisp_pointer(word)) {
+ long *address = (long *) native_pointer(word);
+ if (ctx->start <= address && address < ctx->end)
+ *p += ctx->displacement;
+ nrelocated = 1;
+ } else {
+ relocfn fn = reloctab[widetag_of(word)];
+ if (fn)
+ nrelocated = fn(p, ctx);
+ else
+ nrelocated = 1;
+ }
+ }
+}
+
+static long
+relocate_lose(long *ptr, struct relocator *ctx)
+{
+ lose("no relocation function for header 0x%08x at 0x%08x\n",
+ *ptr, ptr);
+ return 0;
+}
+
+static long
+relocate_unboxed(long *ptr, struct relocator *ctx)
+{
+ return ALIGN(HeaderValue(*ptr) + 1);
+}
+
+static long
+relocate_raw_vector(long *ptr, struct relocator *ctx)
+{
+ return sizetab[widetag_of(*ptr)]((void *) ptr);
+}
+
+static long
+relocate_simple_vector(long *ptr, struct relocator *ctx)
+{
+ /* note: we leave the simple vector header as-is, assuming that
+ * the dumper has marked hash tables needing a re-hash already.
+ * If using the relocation routine is to be used for pages not
+ * written by sb-heapdump, at least replace
+ * vector-valid-hashing-subtype with
+ * sb-vm:vector-must-rehash-subtype here. */
+ return 2;
+}
+
+static long
+relocate_fdefn(long *ptr, struct relocator *ctx)
+{
+ struct fdefn *fdefn = (struct fdefn *) ptr;
+ char *nontramp_raw_addr = (char *) fdefn->fun + FUN_RAW_ADDR_OFFSET;
+
+ sub_relocate(ptr + 1, 2, ctx);
+ if (fdefn->raw_addr == nontramp_raw_addr)
+ fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET);
+ return sizeof(struct fdefn) / sizeof(lispobj);
+}
+
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
+static long
+relocate_closure_header(long *ptr, struct relocator *ctx)
+{
+ struct closure *closure = (struct closure *) ptr;
+ long fun = (long) closure->fun - FUN_RAW_ADDR_OFFSET;
+ sub_relocate(&fun, 1, ctx);
+ closure->fun = fun + FUN_RAW_ADDR_OFFSET;
+ return 2;
+}
+#endif
+
+static long
+relocate_instance(long *ptr, struct relocator *ctx)
+{
+ lispobj nuntagged;
+ struct instance *instance = (struct instance *) ptr;
+ long ntotal = HeaderValue(*ptr);
+
+ sub_relocate((long *) &instance->slots[0], 1, ctx);
+ if (fixnump(instance->slots[0]))
+ /* If the layout is a fixup, the dumper stores `nuntagged'
+ * here for us to find. */
+ nuntagged = instance->slots[0];
+ else {
+ struct layout *layout = natify(instance->slots[0], ctx);
+ nuntagged = layout->n_untagged_slots;
+ }
+
+ sub_relocate(ptr + 2, ntotal - fixnum_value(nuntagged) - 1, ctx);
+ return ntotal + 1;
+}
+
+static long
+relocate_code_header(long *ptr, struct relocator *ctx)
+{
+ long header = *ptr;
+ struct code *code = (struct code *) ptr;
+ long n_header_words = HeaderValue(header);
+ long n_code_words = fixnum_value(code->code_size);
+ long n_words = ALIGN(n_header_words + n_code_words);
+ lispobj ep;
+
+ sub_relocate(ptr + 1, n_header_words - 1, ctx);
+
+ ep = code->entry_points;
+ while (ep != NIL) {
+ struct simple_fun *fun = natify(ep, ctx);
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
+ fun->self = (long) ep + FUN_RAW_ADDR_OFFSET;
+#else
+ fun->self = ep;
+#endif
+ sub_relocate((void *) &fun->next, 1, ctx);
+ sub_relocate((void *) &fun->name, 1, ctx);
+ sub_relocate((void *) &fun->arglist, 1, ctx);
+ sub_relocate((void *) &fun->type, 1, ctx);
+ ep = fun->next;
+ }
+
+#ifdef LISP_FEATURE_X86
+ if (is_lisp_pointer(code->constants[0])) {
+ long word_displacement = ctx->displacement / N_WORD_BYTES;
+ char *code_start
+ = ((char *) code) + n_header_words * N_WORD_BYTES;
+ long *old_start = oldify(ptr, ctx);
+ long *old_end = old_start + n_words;
+
+ struct vector *fixups = natify(code->constants[0], ctx);
+ long n = fixnum_value(fixups->length);
+ long i;
+
+ for (i = 0; i < n; i++) {
+ unsigned long offset = fixups->data[i];
+ long **place = (long **) (code_start + offset);
+ long *old_value = *place;
+
+ if (old_start <= old_value && old_value < old_end)
+ *place = old_value + word_displacement;
+ else
+ *place = old_value - word_displacement;
+ }
+ }
+#endif
+
+ return n_words;
+}
+
+void
+relocate_init()
+{
+ int i;
+
+ for (i = 0; i < ((sizeof reloctab)/(sizeof reloctab[0])); i++)
+ reloctab[i] = relocate_lose;
+
+ for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) {
+ reloctab[EVEN_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)]
+ = RELOCATE_IMMEDIATE;
+ reloctab[ODD_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)]
+ = RELOCATE_IMMEDIATE;
+ }
+
+ reloctab[BIGNUM_WIDETAG] = relocate_unboxed;
+ reloctab[RATIO_WIDETAG] = RELOCATE_BOXED;
+#if N_WORD_BITS == 64
+ reloctab[SINGLE_FLOAT_WIDETAG] = RELOCATE_IMMEDIATE;
+#else
+ reloctab[SINGLE_FLOAT_WIDETAG] = relocate_unboxed;
+#endif
+ reloctab[DOUBLE_FLOAT_WIDETAG] = relocate_unboxed;
+#ifdef LONG_FLOAT_WIDETAG
+ reloctab[LONG_FLOAT_WIDETAG] = relocate_unboxed;
+#endif
+ reloctab[COMPLEX_WIDETAG] = RELOCATE_BOXED;
+#ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
+ reloctab[COMPLEX_SINGLE_FLOAT_WIDETAG] = relocate_unboxed;
+#endif
+#ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
+ reloctab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = relocate_unboxed;
+#endif
+#ifdef COMPLEX_LONG_FLOAT_WIDETAG
+ reloctab[COMPLEX_LONG_FLOAT_WIDETAG] = relocate_unboxed;
+#endif
+ reloctab[SIMPLE_ARRAY_WIDETAG] = RELOCATE_BOXED;
+ reloctab[SIMPLE_BASE_STRING_WIDETAG] = relocate_raw_vector;
+#ifdef SIMPLE_CHARACTER_STRING_WIDETAG
+ reloctab[SIMPLE_CHARACTER_STRING_WIDETAG] = relocate_raw_vector;
+#endif
+ reloctab[SIMPLE_BIT_VECTOR_WIDETAG] = relocate_raw_vector;
+ reloctab[SIMPLE_VECTOR_WIDETAG] = relocate_simple_vector;
+ reloctab[SIMPLE_ARRAY_NIL_WIDETAG] = relocate_raw_vector;
+ reloctab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] = relocate_raw_vector;
+ reloctab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] = relocate_raw_vector;
+ reloctab[SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG] = relocate_raw_vector;
+ reloctab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] = relocate_raw_vector;
+ reloctab[SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG] = relocate_raw_vector;
+ reloctab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] = relocate_raw_vector;
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
+ reloctab[SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG] = relocate_raw_vector;
+#endif
+ reloctab[SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG] = relocate_raw_vector;
+ reloctab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] = relocate_raw_vector;
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
+ reloctab[SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG] = relocate_raw_vector;
+#endif
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
+ reloctab[SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG] = relocate_raw_vector;
+#endif
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
+ reloctab[SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG] = relocate_raw_vector;
+#endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
+ reloctab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = relocate_raw_vector;
+#endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
+ reloctab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] = relocate_raw_vector;
+#endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
+ reloctab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] = relocate_raw_vector;
+#endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
+ reloctab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] = relocate_raw_vector;
+#endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
+ reloctab[SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG] = relocate_raw_vector;
+#endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
+ reloctab[SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG] = relocate_raw_vector;
+#endif
+ reloctab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = relocate_raw_vector;
+ reloctab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = relocate_raw_vector;
+#ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
+ reloctab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = relocate_raw_vector;
+#endif
+#ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
+ reloctab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG]
+ = relocate_raw_vector;
+#endif
+#ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
+ reloctab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG]
+ = relocate_raw_vector;
+#endif
+#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
+ reloctab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG]
+ = relocate_raw_vector;
+#endif
+ reloctab[COMPLEX_BASE_STRING_WIDETAG] = RELOCATE_BOXED;
+#ifdef COMPLEX_CHARACTER_STRING_WIDETAG
+ reloctab[COMPLEX_CHARACTER_STRING_WIDETAG] = RELOCATE_BOXED;
+#endif
+ reloctab[COMPLEX_VECTOR_NIL_WIDETAG] = RELOCATE_BOXED;
+ reloctab[COMPLEX_BIT_VECTOR_WIDETAG] = RELOCATE_BOXED;
+ reloctab[COMPLEX_VECTOR_WIDETAG] = RELOCATE_BOXED;
+ reloctab[COMPLEX_ARRAY_WIDETAG] = RELOCATE_BOXED;
+ reloctab[CODE_HEADER_WIDETAG] = relocate_code_header;
+#ifndef LISP_FEATURE_GENCGC /* FIXME ..._X86 ? */
+ reloctab[SIMPLE_FUN_HEADER_WIDETAG] = relocate_lose;
+ reloctab[RETURN_PC_HEADER_WIDETAG] = relocate_lose;
+#endif
+#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;
+ reloctab[CHARACTER_WIDETAG] = RELOCATE_IMMEDIATE;
+ reloctab[SAP_WIDETAG] = relocate_unboxed;
+ reloctab[UNBOUND_MARKER_WIDETAG] = RELOCATE_IMMEDIATE;
+ reloctab[NO_TLS_VALUE_MARKER_WIDETAG] = RELOCATE_IMMEDIATE;
+ reloctab[WEAK_POINTER_WIDETAG] = RELOCATE_BOXED;
+ reloctab[INSTANCE_HEADER_WIDETAG] = relocate_instance;
+#ifdef LISP_FEATURE_SPARC
+ reloctab[FDEFN_WIDETAG] = RELOCATE_BOXED;
+#else
+ reloctab[FDEFN_WIDETAG] = relocate_fdefn;
+#endif
+}
Added: trunk/sb-heapdump/sb-heapdump.asd
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/sb-heapdump.asd Sun May 21 14:31:55 2006
@@ -0,0 +1,40 @@
+(defpackage :sb-heapdump-system ;-*- mode: lisp -*-
+ (:use :asdf :cl))
+(in-package :sb-heapdump-system)
+
+(defsystem sb-heapdump
+ #+sb-building-contrib :pathname
+ #+sb-building-contrib "SYS:CONTRIB;SB-HEAPDUMP;"
+ :serial t
+ :components ((:file "package")
+ (:file "common")
+ (:file "patch")
+ (:file "dump")
+ (:file "load")
+ (:file "pack")
+ (:file "module"))
+ :depends-on ())
+
+;; fixme
+(sb-alien:load-shared-object
+ (make-pathname
+ :name "relocate"
+ :type "so"
+ :version nil
+ :defaults (component-relative-pathname (find-system :sb-heapdump))))
+
+(defmethod perform :after ((o load-op) (c (eql (find-system 'sb-heapdump))))
+ (provide 'sb-heapdump))
+
+(defmethod perform ((o test-op) (c (eql (find-system 'sb-heapdump))))
+ (oos 'load-op 'sb-heapdump-tests)
+ (oos 'test-op 'sb-heapdump-tests))
+
+(defsystem sb-heapdump-tests
+ :depends-on (sb-rt)
+ :components ((:file "testpack")
+ (:file "test")))
+
+(defmethod perform ((o test-op) (c (eql (find-system :sb-heapdump-tests))))
+ (or (funcall (find-symbol "DO-TESTS" "SB-RT"))
+ (error "test-op failed")))
Added: trunk/sb-heapdump/sb-heapdump.texinfo
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/sb-heapdump.texinfo Sun May 21 14:31:55 2006
@@ -0,0 +1,394 @@
+ at node sb-heapdump
+ at section sb-heapdump
+
+sb-heapdump is a library for SBCL which writes graphs of Lisp objects to
+disk in the same format SBCL normally uses in memory.
+
+sb-heapdump is currently supported on the x86, x86-64, and PPC
+platforms.
+
+ at menu
+* Reading heapfiles::
+* Dumping objects and packages::
+* Optimizing heapfiles::
+* Integration into REQUIRE and ASDF::
+* Executable files::
+* DUMP-OBJECT behaviour for specific classes::
+* DUMP-PACKAGES details::
+ at end menu
+
+Features:
+ at itemize
+ at item
+ sb-heapdump supports @emph{all} kinds of Lisp objects SBCL knows
+ at item
+ reads data back very quickly
+ at item
+ is highly SBCL specific. No attempt at portability is made.
+ at item
+ does expressly @emph{not} define a forward- or backward-compatible format.
+ Upgrades to SBCL @emph{will} break support for previously dumped heapfiles.
+ at item
+ as an extension, can dump entire packages with all their definitions
+ at end itemize
+
+FIXME:
+
+ at itemize
+ at item
+ See below for various FIXME comments.
+ at item
+ sb-heapdump keeps a global hash table of all code objects
+ referencing foreign symbols. Make sure to require sb-heapdump
+ @emph{before} loading any fasls referencing the linkage table.
+ at item
+ Also note that an effort is made to fully support generic functions
+ and CLOS classes and instances, but support for this is considered
+ experimental until someone tells me that all the various caches CLOS
+ keeps are faithfully preserved by dumping.
+ at item
+ separating tagged and untagged objects would help gc performance
+ at item
+ so would starting a new region every few pages (I think)
+ at item
+ what about functions without a fixup vector?
+ at end itemize
+
+ at node Reading heapfiles
+ at subsection Reading heapfiles
+
+ at deffn {Function} LOAD-DUMPFILE (pathname &key customizer suppress-initializer)
+ Load the dumpfile from PATHNAME, then run the initializer
+ specified included in the dumpfile, if any. Call the initializer with
+ the object that has been loaded back and return the initializer's
+ return value. If no initializer is run, return the object directly.
+
+ Multiple heap file segments can be concatenated into one file. In
+ this case, LOAD-DUMPFILE will load all segments found in orde. The
+ last segment's value will be returned. Concatenation can be done
+ using :if-exists :append while dumping, or simply using cat(1).
+
+ Keyword arguments:
+ at itemize
+ @item
+ SUPRRESS-INITIALIZER (default nil) -- if true, suppress running the
+ initializer and directly return the object in the dump file.
+ @item
+ CUSTOMIZER -- override the LOAD-TIME-CUSTOMIZER specified when dumping.
+ See below.
+ at end itemize
+ at end deffn
+
+ at node Dumping objects and packages
+ at subsection Dumping objects and packages
+
+ at deffn {Function} DUMP-OBJECT (object pathname &key if-exists initializer customizer load-time-customizer force print-statistics base-address)
+ Write OBJECT to a heapfile at PATHNAME.
+
+ Recursively walk all the graph of objects referenced from OBJECT and
+ dump them too, except for objects assumed to be `unique'. Unique
+ objects are not dumped unless specified using FORCE; instead they will
+ be assumed to exist in the target image already and references to them
+ will be fixup up at load time. It is an error if such an object
+ cannot be found then. See below for a details.
+
+ Keyword arguments:
+ at itemize
+ at item
+ IF-EXISTS (one of :error (default), :rename-and-delete, or :append) --
+ passed to OPEN. When using :append, a new segment fill be added
+ to an existing heap file. See LOAD-DUMPFILE for details.
+ at item
+ INITIALIZER -- if specified, a function object of one argument to be
+ run after the heap file has been loaded back into memory by
+ LOAD-DUMPFILE. See there for details.
+ at item
+ CUSTOMIZER -- An optional function of one argument called for every
+ object dumped. Possible return values:
+ at itemize
+ at item
+ (a) T
+ Dumping of the object will then proceed normally.)
+ at item
+ (b) As multiple values, (NIL; replacement object)
+ The replacement value will be substituted for every reference
+ to the original value while dumping.
+ at item
+ (c) As multiple values, (:FIXUP; data1; data2)
+ The object will be replaced by a fixup to be resolved at load time.
+ LOAD-DUMPFILE will call LOAD-TIME-CUSTOMIZER with data1 and data2
+ as its arguments and substitute references to the original object
+ for its return value.
+ at end itemize
+ at item
+ LOAD-TIME-CUSTOMIZER -- function to be dumped into the heapfile to
+ resolve user fixups as specified in the description of CUSTOMIZER.
+ Can be overriden at load time using the CUSTOMIZER argument to
+ LOAD-HEAPFILE.
+ at item
+ FORCE -- An optional list of objects specifying that these objects
+ are to be dumped directly even if they would have been replaced
+ with fixups otherwise.
+ at item
+ PRINT-STATISTICS (boolean) -- print statistics about the number and
+ kinds of objects dumped before returning
+ at item
+ BASE-ADDRESS -- a memory address as an integer, aligned to a page
+ boundary. Write the heapfile so that it can be mapped without
+ relocation if memory starting with BASE-ADDRESS is free (and lies
+ within dynamic space).
+ at end itemize
+ at end deffn
+
+ at deffn {Function} DUMP-PACKAGES (packages pathname &key if-exists print-statistics customizer load-time-customizer initializer base-address systems system-packages)
+
+ Dump the entire PACKAGES specified into a dumpfile. This is roughly
+ equivalent to
+ (DUMP-OBJECT packages pathname :FORCE packages)
+ except that it collects additional information about objects named by
+ symbols in the packages specified (including function and class
+ definitions) and makes sure to restore this data after loading.
+
+ Keyword arguments:
+ at itemize
+ at item
+ INITIALIZER -- called with the list of packages after other
+ initialization has been completed.
+ at item
+ IF-EXISTS, PRINT-STATISTICS, CUSTOMIZER, LOAD-TIME-CUSTOMIZER,
+ BASE-ADDRESS --
+ cf. DUMP-OBJECT
+ at item
+ SYSTEMS -- list of ASDF system designators. If specified, prepend
+ a segment to the dumpfile containing the ASDF systems with an
+ initializer that will restore them and require their dependencies
+ before loading the main segment containing PACKAGES.
+ at item
+ SYSTEM-PACKAGES -- list of packages that SYSTEMS were defined in.
+ at end itemize
+ at end deffn
+
+Note that Lisp software can cause extensive changes to a Lisp image
+while it is loaded and run, many of which are not necessarily reflected
+in the actualy home package(s) of the software. DUMP-PACKAGES cannot
+automatically determine which parts of the current Lisp image "belong"
+to the software that is to be dumped. To make such software work with
+DUMP-PACKAGES, users will often have to customize the dumping
+procedure. One way to do this is by specifying a custom INITIALIZER.
+For example, if the software stores data on the plist of symbols not
+contained in the packages to be dumped, write an initializer that
+restores these plists after loading.
+
+
+ at node Optimizing heapfiles
+ at subsection Optimizing heapfiles
+
+Heap files that cannot be mapped to the base-address they were targetted
+for will be relocated automatically. Multiple heap files expected to be
+loaded together (and heap files containing several segments) can be
+relocated in advance to avoid overlap and unnecessary relocation at load
+time.
+
+(However, note that relocation is relatively fast and heap files
+generated by DUMP-PACKAGE usually spend more time in the fixup and
+initialization steps than in relocation.)
+
+
+ at deffn {Function} RELOCATE-DUMPFILES (pathnames &optional base-address)
+
+ Rewrite the dumpfiles so that they will, by default, load into
+ non-overlapping parts of memory, starting with BASE-ADDRESS.
+ at end deffn
+
+ at deffn {Function} RELOCATE-DUMPFILE (pathname &optional base-address)
+
+ Rewrite the dumpfile at PATHNAME so that it will load to BASE-ADDRESS
+ by default.
+ at end deffn
+
+
+ at node Integration into REQUIRE and ASDF
+ at subsection Integration into REQUIRE and ASDF
+
+sb-heapdump installs itself as a provider for REQUIRE. Modules are
+searched in each directory specified by SB-HEAPDUMP:*CENTRAL-REGISTRY*
+with the downcased module name as file name and file type ".heap".
+
+Heap files store in a registry directory should have been dumped using
+the :SYSTEMS argument to DUMP-PACKAGE.
+
+Dependencies of the systems as declared using :DEPENDS-ON are loaded
+using REQUIRE.
+
+Once a heap file has been found and loaded, it is automatically
+registered as an ASDF system and ignored by the sb-heapfile's module
+provider, so further invocations of REQUIRE and ASDF functions will
+compile and load its components as usual.
+
+
+ at deffn {Variable} *CENTRAL-REGISTRY*
+
+ A list of directory designators evaluated and searched in order when
+ looking for heapfile modules. Defaults to the current directory and
+ $SBCL_HOME in this order.
+ at end deffn
+
+ at deffn {Generic Function} DUMP-SYSTEM (system)
+
+ Convenience function that ASDF systems can define a method that will
+ dump the system into a file. See demo.lisp in the sb-heapdump
+ distribution for examples.
+ at end deffn
+
+
+ at node Executable files
+ at subsection Executable files
+
+ at deffn {Function} MAKE-EXECUTABLE (heapfile &key output-pathname if-exists main-function)
+
+ Create a file called OUTPUT-PATHNAME consisting of a trampoline binary
+ and a copy of HEAPFILE. (Optionally, an additional heapfile segment
+ is appended that calls MAIN-FUNCTION with the binary's command line
+ arguments in its initializer.)
+
+ When executed, the generated file will run the `sbcl' binary as found
+ in $PATH to load itself.
+
+ OUTPUT-PATHNAME defaults to the name obtained by removing the type
+ component from the pathname HEAPFILE. For example, `foo.heap' is
+ copied into `foo'.
+ at end deffn
+
+
+ at node DUMP-OBJECT behaviour for specific classes
+ at subsection DUMP-OBJECT behaviour for specific classes
+
+The following types of objects can be dumped and are always dumped
+literally:
+ at itemize
+ at item
+ Immediate values (FIXNUM and CHARACTER)
+ at item
+ BIGNUMs, SINGLE-FLOAT, DOUBLE-FLOAT, RATIO, COMPLEX
+ at item
+ Lists
+ at item
+ ARRAY (all types of arrays are supported, including single- and
+ multi-dimensional arrays of all array element types known by SBCL,
+ whether simple or not. This includes strings.)
+ at item
+ Instances (technically, SB-KERNEL:INSTANCE), including structure
+ instances, CLOS instances, and conditions. [Note: CLOS support is
+ experimental.]
+ at item
+ Code components (if specified literally; see below for the fixup
+ behaviour of functions)
+ at item
+ Closures
+ at item
+ Uninterned symbols
+ at item
+ Value cells (fixme: whatever that is anyway)
+ at item
+ System area pointers (SAPs)
+ at item
+ Weak pointers. (The weak pointer value will be dumped and the weak
+ reference to it preserved if the value is either (i) reachable
+ through a non-weak reference from the object graph being dumped or
+ (ii) treated as a fixup. Else the weak pointer will load as a
+ broken reference.)
+ at end itemize
+
+The following types of objects are dumped only if specified by the FORCE
+argument, otherwise they are replaced by fixups.
+ at itemize
+ at item
+ Packages
+ at item
+ Interned symbols (forcing a package also forces all symbols with
+ that package as their home package)
+ at item
+ Classes (technically, all of SB-KERNEL:LAYOUT, SB-KERNEL:CLASSOID
+ and SB-KERNEL:CLASS). Forcing a symbol also forces classes named by
+ that symbol.
+ [FIXME! KLUDGE! There is an unnamed class in SBCL. It is currently
+ dumped unconditionally, which cannot be right.]
+ at item
+ NAMED-TYPE: Named types are replaced by a fixup if named by a symbol
+ that is not being forced. The fixup will automatically re-create
+ the named type at load time, if necessary.
+ at end itemize
+
+The following types of objects are dumped according to more complex
+heuristics. (Notionally, these objects will be replaced by a fixup if
+they are identified by a symbol that is not forced.)
+ at itemize
+ at item
+ Except as noted below, ordinary functions (simple-funs) are replaced
+ by fixups if all of the following conditions are true: (i) The
+ function object itself is not being forced. (ii) The function is
+ named by a symbol or is named (SETF symbol). (iii) The symbol is
+ not being forced. (iv) FDEFINITION for that function name actually
+ returns the function object in question. --- If a function is not
+ replaced by a fixup, its code component is dumped, which implies
+ dumping all its other entry points.
+ at item
+ funcallable instances -- FIXME: except as noted below, funcallable
+ instances are currently dumped unconditionally. That can't be
+ right, shouldn't the rules for simple-fun's apply here, too?
+ at item
+ Generic functions: Slot accessors (SB-PCL::SLOT-ACCESSOR) are never
+ dumped and instead recreated while loading the heap file, if
+ necessary. Other generic function are treated like ordinary
+ functions (see above).
+ at item
+ An FDEFN object is replaced by a fixup unless any of the following
+ conditions is true: (i) The function it points to is dumped
+ literally. (ii) Its name is a forced symbol. (iii) Its name is a
+ list containing a forced symbol. (iv) It points to a CTOR or
+ SLOT-ACCESSOR.
+ at end itemize
+
+The following types of objects are never dumped literally:
+ at itemize
+ at item
+ Although technically simple functions, SB-PCL::FAST-METHODs are
+ never dumped literally and instead recreated while loading the heap
+ file, if necessary. [FIXME! there are fast methods that are
+ closures, what happens then?]
+ at item
+ Although technically funcallable instances, SB-PCL::CTORs are never
+ dumped and instead recreated while loading the heap file, if
+ necessary.
+ at item
+ ARRAY-TYPEs are never dumped and instead recreated while loading the
+ heap file, if necessary.
+ at end itemize
+
+fixme: are there CTYPE structures other than named-type and array-type
+that can and need to be fixed up? [union-type has a cache, but does the
+compiler depend on that?]
+
+
+ at node DUMP-PACKAGES details
+ at subsection DUMP-PACKAGES details
+
+For every package and every symbol that has one of these packages as its
+home package, DUMP-PACKAGE installs an initializer that will restore
+ at itemize
+ at item
+ all class cells named by this symbol
+ at item
+ for all SPECIALIZER-DIRECT-METHODs of those classes, the
+ method-function-plist of their FAST-METHODs
+as well as most info-types in the compiler's INFO database for:
+ at item
+ the symbol itself
+ at item
+ the name (SETF symbol)
+ at item
+ the slot reader, writer, and boundp accessors for all slot
+ definitions of classes named by this symbol
+ at item
+ the names of all the FAST-METHODs
+ at end itemize
Added: trunk/sb-heapdump/test.lisp
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/test.lisp Sun May 21 14:31:55 2006
@@ -0,0 +1,117 @@
+;;; -*- indent-tabs-mode: nil -*-
+
+(defpackage :sb-heapdump-test
+ (:use :cl :sb-heapdump :sb-rt))
+
+(in-package :sb-heapdump-test)
+
+(rem-all-tests)
+
+(defun %load-dumpfile (&rest args)
+ (multiple-value-prog1
+ (apply #'load-dumpfile args)
+ (sb-ext:gc :full t)))
+
+(defparameter *test-path*
+ (merge-pathnames (make-pathname :name :unspecific :type :unspecific
+ :version :unspecific)
+ *load-truename*)
+ "Directory for temporary test files.")
+
+(defparameter *test-file*
+ (merge-pathnames #p"test.heap" *test-path*))
+
+(let ((b sb-heapdump::*default-base-address*))
+ (defun make-address ()
+ (incf b (* 1 1024 1024))))
+
+(deftest hash-table.1
+ (progn
+ (dump-object (let ((x (make-hash-table)))
+ (setf (gethash 'foo x) 'bar)
+ x)
+ *test-file*
+ :base-address (make-address)
+ :if-exists :rename-and-delete)
+ (values (gethash 'foo (%load-dumpfile *test-file*))))
+ bar)
+
+(deftest code-component.1
+ (progn
+ (dump-object (lambda ())
+ *test-file*
+ :base-address (make-address)
+ :if-exists :rename-and-delete)
+ (funcall (%load-dumpfile *test-file*)))
+ nil)
+
+(defun ff (x) (if (zerop x) 1 (* x (ff (1- x)))))
+
+(deftest code-component.2
+ (progn
+ (dump-object #'ff
+ *test-file*
+ :force t
+ :base-address (make-address)
+ :if-exists :rename-and-delete)
+ (funcall (%load-dumpfile *test-file*) 3))
+ 6)
+
+(deftest initializer-is-fixup.1
+ (progn
+ (dump-object '("foo" "bar")
+ *test-file*
+ :base-address (make-address)
+ :force t
+ :initializer #'print
+ :if-exists :rename-and-delete)
+ (%load-dumpfile *test-file*)
+ t)
+ t)
+
+(deftest weak-pointer.1
+ (progn
+ (dump-object (list '#1=#:foo (sb-ext:make-weak-pointer '#1#))
+ *test-file*
+ :base-address (make-address)
+ :if-exists :rename-and-delete)
+ (destructuring-bind (thing wp)
+ (%load-dumpfile *test-file*)
+ (eq thing (sb-ext:weak-pointer-value wp))))
+ t)
+
+(deftest weak-pointer.2
+ (progn
+ (dump-object (list (sb-ext:make-weak-pointer (list 1 2 3)))
+ *test-file*
+ :base-address (make-address)
+ :if-exists :rename-and-delete)
+ (sb-ext:weak-pointer-value (car (%load-dumpfile *test-file*))))
+ nil
+ nil)
+
+(deftest weak-pointer.3
+ (progn
+ (dump-object (list (sb-ext:make-weak-pointer :foo))
+ *test-file*
+ :base-address (make-address)
+ :if-exists :rename-and-delete)
+ (sb-ext:weak-pointer-value (car (%load-dumpfile *test-file*))))
+ :foo
+ t)
+
+(deftest package.1
+ (progn
+ (dump-packages '(:scratch)
+ *test-file*
+ :base-address (make-address)
+ :if-exists :rename-and-delete)
+ (delete-package :scratch)
+ (%load-dumpfile *test-file*)
+ (let ((i (symbol-value (find-symbol "*I*" "SCRATCH"))))
+ (and (typep i (find-symbol "SUB" "SCRATCH"))
+ (eql (funcall (find-symbol "A" "SCRATCH") i) 1)
+ (eql (funcall (find-symbol "B" "SCRATCH") i) 2)
+ (eql (funcall (find-symbol "GF" "SCRATCH") i) 2)
+ (eql (funcall (find-symbol "FN" "SCRATCH") i) 2))))
+ t)
Added: trunk/sb-heapdump/testpack.lisp
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/testpack.lisp Sun May 21 14:31:55 2006
@@ -0,0 +1,24 @@
+;;; -*- indent-tabs-mode: nil -*-
+
+(defpackage :scratch
+ (:use :cl))
+
+(in-package :scratch)
+
+(defclass super () ((a :initarg :a :accessor a)))
+(defclass sub (super) ((b :initarg :b :accessor b)))
+
+(defmethod print-object ((object super) stream)
+ (print-unreadable-object (object stream :type t :identity t)
+ (format stream "a=~A" (gf object))))
+
+(defparameter *i* (make-instance 'sub :a 1 :b 2))
+
+(defmethod gf ((object super))
+ (a object))
+
+(defmethod gf ((object sub))
+ (b object))
+
+(defun fn (a)
+ (gf a))
Added: trunk/sb-heapdump/trampoline.c
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/trampoline.c Sun May 21 14:31:55 2006
@@ -0,0 +1,85 @@
+/* -*- indent-tabs-mode: nil -*- */
+#include <stdlib.h>
+#include <stdio.h>
+#include <unistd.h>
+#include <string.h>
+#include <math.h>
+#include <limits.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+
+static void
+syserr(char *str)
+{
+ perror(str);
+ exit(1);
+}
+
+#define FORMAT_CONTROL "(sb-heapdump:load-dumpfile \"%s\" :start %ld :end %ld)"
+static char *
+format_form(char *this, long start, long end)
+{
+ int ndigits = (int) (log(ULONG_MAX) / log(10)) + 1;
+ int n = strlen(FORMAT_CONTROL) + 2 * ndigits;
+ char *form = malloc(n + 1);
+ if (!form) exit(1);
+ snprintf(form, n, FORMAT_CONTROL, this, start, end);
+ return form;
+}
+
+static char *extra_args[] = {
+ "sbcl",
+ "--noinform",
+ "--userinit", "/dev/null",
+ "--eval",
+ "(unless (find-package :sb-heapdump)"
+ " (format t \"~&error: core file does not include sb-heapdump~%\")"
+ " (sb-ext:quit :unix-status 1))",
+ "--eval", 0,
+ "--eval", "(sb-ext:quit :unix-status 0)",
+ "--end-toplevel-options",
+ 0
+};
+
+static void
+parse_file(char *this, long *start, long *end)
+{
+ int fd = open(this, O_RDONLY, 0);
+ if (fd == -1) syserr("open");
+ if ( (*end = lseek(fd, -sizeof(long), SEEK_END)) == -1)
+ syserr("lseek");
+ if (read(fd, start, sizeof(long)) != sizeof(long)) syserr("read");
+ close(fd);
+}
+
+int
+main(int argc, char **argv)
+{
+ int n = sizeof(extra_args) / sizeof(char *) - 1;
+ char *this = argv[0];
+ char **args = malloc((n + argc + 1) * sizeof(char *));
+ int i;
+ long start, end;
+
+ if (!args) syserr("malloc");
+ if (strchr(this, '"') || strchr(this, '\\')) {
+ fputs("error: file name contains invalid character\n", stderr);
+ exit(1);
+ }
+ parse_file(this, &start, &end);
+
+ for (i = 0; i < n; i++)
+ if (extra_args[i])
+ args[i] = extra_args[i];
+ else
+ args[i] = format_form(this, start, end);
+ for (i = 1; i < argc; i++)
+ args[n + i] = argv[i];
+ args[n + argc + 1] = 0;
+
+ execvp("sbcl", args);
+ perror("exec");
+ fputs("error: cannot find SBCL runtime environment\n", stderr);
+ fputs("make sure sbcl(1) can be found in $PATH\n", stderr);
+ exit(1);
+}
Modified: trunk/scripts/fetch-sbcl
==============================================================================
--- trunk/scripts/fetch-sbcl (original)
+++ trunk/scripts/fetch-sbcl Sun May 21 14:31:55 2006
@@ -10,8 +10,7 @@
sbcl-0.9.12-source.tar.bz2 \
sbcl-0.9.12 \
sbcl
-./scripts/aux/fetch-cvs \
- /home/david/cvsroot \
- sb-heapdump \
- "-r HEAD"
+./scripts/aux/fetch-svn \
+ svn://common-lisp.net/project/steeldump/svn/trunk/sb-heapdump \
+ sb-heapdump
cp -r src/sb-heapdump src/sbcl/contrib
More information about the Steeldump-cvs
mailing list