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 () ,@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 ,@body))) + ,@(if declarationp (cdr body) body))))) + +(defmacro lambda ((&rest args) &body body) + `(cl:lambda ,args ,@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 @@ +@node sb-heapdump +@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. + +@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:: +@end menu + +Features: +@itemize +@item + sb-heapdump supports @emph{all} kinds of Lisp objects SBCL knows +@item + reads data back very quickly +@item + is highly SBCL specific. No attempt at portability is made. +@item + does expressly @emph{not} define a forward- or backward-compatible format. + Upgrades to SBCL @emph{will} break support for previously dumped heapfiles. +@item + as an extension, can dump entire packages with all their definitions +@end itemize + +FIXME: + +@itemize +@item + See below for various FIXME comments. +@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. +@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. +@item + separating tagged and untagged objects would help gc performance +@item + so would starting a new region every few pages (I think) +@item + what about functions without a fixup vector? +@end itemize + +@node Reading heapfiles +@subsection Reading heapfiles + +@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: +@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. +@end itemize +@end deffn + +@node Dumping objects and packages +@subsection Dumping objects and packages + +@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: +@itemize +@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. +@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. +@item + CUSTOMIZER -- An optional function of one argument called for every + object dumped. Possible return values: +@itemize +@item + (a) T + Dumping of the object will then proceed normally.) +@item + (b) As multiple values, (NIL; replacement object) + The replacement value will be substituted for every reference + to the original value while dumping. +@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. +@end itemize +@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. +@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. +@item + PRINT-STATISTICS (boolean) -- print statistics about the number and + kinds of objects dumped before returning +@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). +@end itemize +@end deffn + +@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: +@itemize +@item + INITIALIZER -- called with the list of packages after other + initialization has been completed. +@item + IF-EXISTS, PRINT-STATISTICS, CUSTOMIZER, LOAD-TIME-CUSTOMIZER, + BASE-ADDRESS -- + cf. DUMP-OBJECT +@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. +@item + SYSTEM-PACKAGES -- list of packages that SYSTEMS were defined in. +@end itemize +@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. + + +@node Optimizing heapfiles +@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.) + + +@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. +@end deffn + +@deffn {Function} RELOCATE-DUMPFILE (pathname &optional base-address) + + Rewrite the dumpfile at PATHNAME so that it will load to BASE-ADDRESS + by default. +@end deffn + + +@node Integration into REQUIRE and ASDF +@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. + + +@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. +@end deffn + +@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. +@end deffn + + +@node Executable files +@subsection Executable files + +@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'. +@end deffn + + +@node DUMP-OBJECT behaviour for specific classes +@subsection DUMP-OBJECT behaviour for specific classes + +The following types of objects can be dumped and are always dumped +literally: +@itemize +@item + Immediate values (FIXNUM and CHARACTER) +@item + BIGNUMs, SINGLE-FLOAT, DOUBLE-FLOAT, RATIO, COMPLEX +@item + Lists +@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.) +@item + Instances (technically, SB-KERNEL:INSTANCE), including structure + instances, CLOS instances, and conditions. [Note: CLOS support is + experimental.] +@item + Code components (if specified literally; see below for the fixup + behaviour of functions) +@item + Closures +@item + Uninterned symbols +@item + Value cells (fixme: whatever that is anyway) +@item + System area pointers (SAPs) +@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.) +@end itemize + +The following types of objects are dumped only if specified by the FORCE +argument, otherwise they are replaced by fixups. +@itemize +@item + Packages +@item + Interned symbols (forcing a package also forces all symbols with + that package as their home package) +@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.] +@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. +@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.) +@itemize +@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. +@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? +@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). +@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. +@end itemize + +The following types of objects are never dumped literally: +@itemize +@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?] +@item + Although technically funcallable instances, SB-PCL::CTORs are never + dumped and instead recreated while loading the heap file, if + necessary. +@item + ARRAY-TYPEs are never dumped and instead recreated while loading the + heap file, if necessary. +@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?] + + +@node DUMP-PACKAGES details +@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 +@itemize +@item + all class cells named by this symbol +@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: +@item + the symbol itself +@item + the name (SETF symbol) +@item + the slot reader, writer, and boundp accessors for all slot + definitions of classes named by this symbol +@item + the names of all the FAST-METHODs +@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