+ Steeldump is an unofficial APT repository for applications written
+ in Common Lisp.
+
+
+
+
+ Steeldump provides binary packages based on
+ SBCL.
+
+
+ It uses sb-heapdump as the binary format.
+
+
+ The focus is on end-user applications, with libraries being pulled in
+ only as necessary.
+
+
+ Currently only for x86 (built by David Lichteblau on Debian testing).
+
+
+
+
+ All packages included are assumed to be Free Software under
+ various different licenses. No warranty whatsoever can be
+ provided for Steeldump. "Now fear, comprehensively."
+
+
+
News
+ 2006-05-21
+
+ First public release. Please test gently. Based on SBCL 0.9.12.
+
+
+ Changes since the very first #lisp preview release:
+
+ Changed: ASDF integration. No more startup messages.
+
+
+
+
+ Installation
+
+
+
+ Add the following line to /etc/apt/sources.list, then run
+ aptitude update.
+
+
deb http://common-lisp.net/project/steeldump unstable main
+
+
+ Packages are all named steeldump-foo. E.g., to
+ install climacs, type aptitude install
+ steeldump-climacs. All packages install exclusively to
+ /opt/steeldump and do not interact with the "normal"
+ Lisp packages included in Debian at all.
+
+
+ There are no source code packages, but full source code is
+ included in each binary package. (Except for SBCL itself, which
+ is packaged as steeldump-sbcl with source code only
+ for the contribs, as usual.)
+
+
+
+ Usage
+
+
+
+
+ Binaries (for the applications) can be found in
+ /opt/steeldump/bin.
+
+
+ SBCL can be started manually using /opt/steeldump/bin/sbcl.
+
+ (Make sure that $SBCL_HOME is not set incorrectly when
+ doing so. A correct setting for this variable would be
+ /opt/steeldump/lib/sbcl, but that value is already compiled into
+ the SBCL binary, so it is not necessary to override it.)
+
+
+ bin/sbcl loads user init files (~/.sbclrc). The
+ application scripts do not.
+
+
+ To load heapdumped systems at the Lisp REPL manually, use
+ (require :foo).
+
+
+ It is possible to use ASDF's load-op instead, although
+ that just ends up calling require through a trampoline
+ system. Once the heap file has been loaded, however, a real
+ asdf system object takes charge.
+
+
+ Implementation detail: To save a little space, source code is
+ installed without fasls. Instead, the fasls are replaced with
+ (essentially) empty files that just have the correct timestamp
+ to make ASDF come to the conclusion that it has nothing to do.
+
+
+
+
+ How to report problems
+
+
+
+ If you encounter something you think is a bug, please try to find
+ out whether the problem lies with steeldump or with the
+ upstream application/library.
+
+
+ If you believe steeldump is to blame, please send bug reports to
+ steeldump-devel at common-lisp.net
+ to avoid pestering upstream maintainers with problems they cannot
+ know anything about. If possible, please include a patch. See
+ below for instructions on the steeldump scripts.
+
+
+ If, however, the bug is also present is the upstream source code,
+ please send your report directly to the upstream project. Thanks.
+
+
+
+ Building Steeldump
+
+
+
+ (You can skip this section if you just want to use steeldump
+ packages normally. See above for installation instructions.)
+
+
+ To help debugging or developing Steeldump, the following steps
+ should be enough to build your own steeldump packages:
+
+
+
+ Set up a chroot environment or virtual machine to compile
+ steeldump in.
+
+
+ If you really do not want to do this, keep this in mind:
+ Steeldump must be compiled in the exact same location
+ where it is going to be installed into,
+ /opt/steeldump. So you cannot run the steeldump
+ scripts in a filesystem where steeldump packages are already
+ installed.
+
+
+ Although it does not address safety issues, you can obviously
+ build a mock-up chroot very easily using mount -o bind,
+ so this should not be too much of an issue.
+
+
+ Create a new directory /opt/steeldump. In the build
+ environment, this directory should be owned by a non-root user.
+ (The build scripts will only run sudo briefly for each
+ package to fix file ownership before packaging the files up.
+ Building should be done normally under your non-root account.)
+
+
+ Check out the steeldump scripts from Subversion:
+
$ cd /opt/steeldump
+$ svn co svn://common-lisp.net/project/steeldump/svn/trunk/scripts
+
+
+ Run the first script:
+
/opt/steeldump$ ./scripts/init
+ -- or just look at what it does. It merely creates a few
+ directories and checks whether required software is installed.
+ CMUCL is used for building (you can use the debian-provided
+ cmucl package), and dpkg-dev tools as well as sudo are needed.
+
+
+ The first package you need to download and build is SBCL:
+
+ And that's it. After makedeb-all, you can find all packages in
+ the pool directory.
+
+
+ While debugging, however, you will probably want to build
+ individual packages instead of all in one go:
+
+
+
+ For every system, there is a separate fetch-foo
+ script. These fetch-scripts do not track dependencies
+ for you. When not using fetch-all, make sure to
+ download everything you need before trying to build.
+
+
+ The build-foo scripts can be invoked in an
+ arbitrary order. For example, building climacs will
+ automatically compile mcclim if it had not been compiled
+ yet. However, it does not actually create the dumpfile
+ for mcclim, you will still have to call build-mcclim
+ eventually before you can make its .deb file.
+
+
+ Finally, for makedeb-all note that it has one advantage
+ over the individual makedeb-foo scripts: Before
+ calling out to the others, makedeb-all relocates the
+ heap files to non-overlapping locations, speeding up loading of
+ the heap files a little.
+
+
+
+ If you got this far and have working packages in
+ /opt/steeldump/pool, send me a postcard.
+
+
+
+ Extending Steeldump
+
+
+
+ (You can skip this section if you just want to use steeldump
+ packages normally. See above for installation instructions.)
+
+
+ To add a new package called "blubba", create these files:
+
+
+
+ /opt/steeldump/scripts/fetch-blubba
+ This script must put the source code into
+ /opt/steeldump/src/blubba. Remove version numbers from
+ the directory name, if any.
+ Look at the other fetch scripts for ideas. Usually it is enough
+ to call one of the helper scripts, aux/fetch-url,
+ aux/fetch-cvs, or aux/fetch-svn. If you have
+ to patch the source code, this script is the right place to do
+ that.
+
+
+ /opt/steeldump/scripts/build-blubba
+ Usually this script is trivial and just
+ calls build-system. Copy
+ over /opt/steeldump/scripts/build-SAMPLE and change the
+ system name from "SAMPLESSYTEMNAME" to "blubba". This script
+ is the right place to call "make" if the system includes C code.
+
+
+ /opt/steeldump/scripts/lisp/build-blubba.lisp
+ This Lisp script is less trivial. Starting from the sample file
+ /opt/steeldump/scripts/lisp/build-SAMPLE.lisp, change
+ the system name from "SAMPLE" to "blubba", but review the
+ heap dumping logic carefully. The heap dumper needs to be told
+ about:
+
+
+ The packages that are to be dumped (look out for multiple
+ defpackage forms). This is the first argument
+ to dump-system.
+
+
+ The ASDF systems involved. If the .asd file contains
+ multiple system definitions, all of them must be listed
+ manually in the build script. (The :system
+ argument.)
+
+
+ The name of the package the .asd files defines and uses.
+ (The :system-package argument.)
+
+
+ You now have a first draft of the dumping script. Beware that
+ dumping is not the part where things tend to fail, it is the
+ loading and running of heap files where mistakes show up. The
+ heuristic used by the heapdumper is that it thinks in terms of
+ packages. For many systems, you will have to supply more
+ information than just the package names, because the software
+ often installs objects into variables contained
+ in other packages, slots of objects the heap dumper
+ cannot know about, etc.
+
+
+ Refer to sb-heapdump documentation on the precise logic used
+ by the dumper.
+
+
+ For CLIM systems in particular, application-defined command
+ tables and presentation types need to be extracted from
+ McCLIM-internal tables. CLIM also has methods that are
+ eql-specializing on objects like +flipping-ink+, so we must
+ guarantee uniqueness of these objects. For details, see
+ the build scripts for gsharp and climacs.
+
+
+ Any CLOS usage can be tricky. The heap dumper will (a)
+ include generic functions and all their methods in the
+ package the generic function's name is in (for example, the
+ MCCLIM package), and (b) additional methods in a different
+ package if those methods specialize on a class named by a
+ symbol in that other package (for example, methods defined
+ for classes in the CLIMACS package). One corollary of these
+ rules is that we must not dump the McCLIM package after
+ having loaded Climacs into the same core, because then
+ loading of McCLIM would fail trying to find the CLIMACS
+ package.
+
+
+
+
+ /opt/steeldump/scripts/descriptions/blubba
+ This file ends up as the Description: header in the
+ Debian package's control file.
+ Again there is a skeleton file:
+ /opt/steeldump/scripts/descriptions/SAMPLE.
+
+
+ /opt/steeldump/scripts/makedeb-blubba
+ This scripts collect all files to be installed and creates the
+ .deb archive. Starting
+ with /opt/steeldump/scripts/makedeb-SAMPLE,
+ replace SAMPLESYSTEMNAME with "blubba", and DEPENDENCIES with other
+ steeldump packages that "blubba" depends on. Omit the
+ "steeldump-" prefix and version number, the helper script
+ inserts those for you.
+
+
+
+
Added: trunk/steeldump-web/steeldump.css
==============================================================================
--- (empty file)
+++ trunk/steeldump-web/steeldump.css Sun May 21 14:33:08 2006
@@ -0,0 +1,100 @@
+div.sidebar {
+ float: right;
+ min-width: 15%;
+ padding: 0pt 5pt 5pt 5pt;
+ font-family: verdana, arial;
+}
+
+a {
+ text-decoration: none;
+ color: #000000;
+ border-bottom: 1px dotted black;
+ border-top: 1px solid white;
+ border-left: 1px solid white;
+ border-right: 1px solid white;
+}
+
+.sidebar a {
+ border-top: 1px solid #eeeeee;
+ border-left: 1px solid #eeeeee;
+ border-right: 1px solid #eeeeee;
+}
+
+a:hover {
+ color: #000000;
+ border: 1px solid black;
+}
+
+div.sidebar-title {
+ font-weight: bold;
+ background-color: #009c00;
+ border: solid #009c00;
+ border-top-width: 1px;
+ border-bottom-width: 0px;
+ border-left-width: 4px;
+ border-right-width: 0px;
+ margin: 0em 2pt 1px 2em;
+}
+
+div.sidebar-title a {
+ color: #ffffff;
+}
+
+div.sidebar-main {
+ background-color: #eeeeee;
+ border: solid #009c00;
+ border-top-width: 0px;
+ border-bottom-width: 0px;
+ border-left-width: 4px;
+ border-right-width: 0px;
+ margin: 0em 2pt 1em 2em;
+ padding-top: 2px;
+ padding-left: 2px;
+}
+
+div.sidebar ul {
+ list-style-type: square;
+ padding: 0pt 0pt 0pt 1em;
+ margin: 0 0 1em;
+}
+
+div.sidebar ul.sub {
+ list-style-type: disc;
+ padding: 0pt 0pt 0pt 1em;
+ margin: 0 0 1em;
+}
+
+body {
+ color: #000000;
+ background-color: #ffffff;
+ margin-right: 0pt;
+ margin-bottom: 10%;
+ margin-left: 40px;
+ padding-left: 30px;
+ font-family: verdana, arial;
+ background-image: url(bg.png);
+ background-position: top left;
+ background-attachment: fixed;
+ background-repeat: no-repeat;
+}
+
+h1,h2,h3 {
+ margin-left: -30px;
+}
+
+pre {
+ background-color: #eeeeee;
+ border: solid 1px #d0d0d0;
+ padding: 1em;
+ margin-right: 10%;
+}
+
+.def {
+ background-color: #ddddff;
+ font-weight: bold;
+}
+
+.nomargin {
+ margin-bottom: 0;
+ margin-top: 0;
+}
From dlichteblau at common-lisp.net Sun May 21 18:28:11 2006
From: dlichteblau at common-lisp.net (dlichteblau at common-lisp.net)
Date: Sun, 21 May 2006 14:28:11 -0400 (EDT)
Subject: [steeldump-cvs] r2 - in trunk/scripts: . aux data descriptions lisp
patches
Message-ID: <20060521182811.F27AE58340@common-lisp.net>
Author: dlichteblau
Date: Sun May 21 14:28:03 2006
New Revision: 2
Added:
trunk/scripts/
trunk/scripts/VERSION
trunk/scripts/aux/
trunk/scripts/aux/asd (contents, props changed)
trunk/scripts/aux/build-system (contents, props changed)
trunk/scripts/aux/fetch-cvs (contents, props changed)
trunk/scripts/aux/fetch-svn (contents, props changed)
trunk/scripts/aux/fetch-url (contents, props changed)
trunk/scripts/aux/makedeb-helper (contents, props changed)
trunk/scripts/aux/wipe-fasls (contents, props changed)
trunk/scripts/aux/write-dummy-asd (contents, props changed)
trunk/scripts/build-SAMPLE
trunk/scripts/build-all (contents, props changed)
trunk/scripts/build-beirc (contents, props changed)
trunk/scripts/build-cl-fad (contents, props changed)
trunk/scripts/build-cl-irc (contents, props changed)
trunk/scripts/build-cl-ppcre (contents, props changed)
trunk/scripts/build-climacs (contents, props changed)
trunk/scripts/build-clx (contents, props changed)
trunk/scripts/build-esa (contents, props changed)
trunk/scripts/build-flexi-streams (contents, props changed)
trunk/scripts/build-flexichain (contents, props changed)
trunk/scripts/build-gsharp (contents, props changed)
trunk/scripts/build-mcclim (contents, props changed)
trunk/scripts/build-sbcl (contents, props changed)
trunk/scripts/build-spatial-trees (contents, props changed)
trunk/scripts/build-split-sequence (contents, props changed)
trunk/scripts/build-tab-layout (contents, props changed)
trunk/scripts/build-trivial-gray-streams (contents, props changed)
trunk/scripts/build-trivial-sockets (contents, props changed)
trunk/scripts/data/
trunk/scripts/data/beirc (contents, props changed)
trunk/scripts/data/clim-listener
trunk/scripts/data/climacs (contents, props changed)
trunk/scripts/data/gsharp (contents, props changed)
trunk/scripts/descriptions/
trunk/scripts/descriptions/SAMPLE
trunk/scripts/descriptions/beirc
trunk/scripts/descriptions/cl-fad
trunk/scripts/descriptions/cl-irc
trunk/scripts/descriptions/cl-ppcre
trunk/scripts/descriptions/climacs
trunk/scripts/descriptions/clx
trunk/scripts/descriptions/esa
trunk/scripts/descriptions/flexi-streams
trunk/scripts/descriptions/flexichain
trunk/scripts/descriptions/gsharp
trunk/scripts/descriptions/mcclim
trunk/scripts/descriptions/sbcl
trunk/scripts/descriptions/spatial-trees
trunk/scripts/descriptions/split-sequence
trunk/scripts/descriptions/tab-layout
trunk/scripts/descriptions/trivial-gray-streams
trunk/scripts/descriptions/trivial-sockets
trunk/scripts/fetch-all (contents, props changed)
trunk/scripts/fetch-beirc (contents, props changed)
trunk/scripts/fetch-cl-fad (contents, props changed)
trunk/scripts/fetch-cl-irc (contents, props changed)
trunk/scripts/fetch-cl-ppcre (contents, props changed)
trunk/scripts/fetch-climacs (contents, props changed)
trunk/scripts/fetch-clx (contents, props changed)
trunk/scripts/fetch-esa (contents, props changed)
trunk/scripts/fetch-flexi-streams (contents, props changed)
trunk/scripts/fetch-flexichain (contents, props changed)
trunk/scripts/fetch-gsharp (contents, props changed)
trunk/scripts/fetch-mcclim (contents, props changed)
trunk/scripts/fetch-sbcl (contents, props changed)
trunk/scripts/fetch-spatial-trees (contents, props changed)
trunk/scripts/fetch-split-sequence (contents, props changed)
trunk/scripts/fetch-tab-layout (contents, props changed)
trunk/scripts/fetch-trivial-gray-streams (contents, props changed)
trunk/scripts/fetch-trivial-sockets (contents, props changed)
trunk/scripts/generate-dists (contents, props changed)
trunk/scripts/init (contents, props changed)
trunk/scripts/lisp/
trunk/scripts/lisp/build-SAMPLE.lisp
trunk/scripts/lisp/build-beirc.lisp
trunk/scripts/lisp/build-cl-fad.lisp
trunk/scripts/lisp/build-cl-irc.lisp
trunk/scripts/lisp/build-cl-ppcre.lisp
trunk/scripts/lisp/build-climacs.lisp
trunk/scripts/lisp/build-clx.lisp
trunk/scripts/lisp/build-esa.lisp
trunk/scripts/lisp/build-flexi-streams.lisp
trunk/scripts/lisp/build-flexichain.lisp
trunk/scripts/lisp/build-gsharp.lisp
trunk/scripts/lisp/build-mcclim.lisp
trunk/scripts/lisp/build-sbcl.lisp
trunk/scripts/lisp/build-spatial-trees.lisp
trunk/scripts/lisp/build-split-sequence.lisp
trunk/scripts/lisp/build-tab-layout.lisp
trunk/scripts/lisp/build-trivial-gray-streams.lisp
trunk/scripts/lisp/build-trivial-sockets.lisp
trunk/scripts/lisp/clim-helper.lisp
trunk/scripts/lisp/hack-asdf.lisp
trunk/scripts/lisp/relocate.lisp
trunk/scripts/makedeb-SAMPLE
trunk/scripts/makedeb-all (contents, props changed)
trunk/scripts/makedeb-beirc (contents, props changed)
trunk/scripts/makedeb-cl-fad (contents, props changed)
trunk/scripts/makedeb-cl-irc (contents, props changed)
trunk/scripts/makedeb-cl-ppcre (contents, props changed)
trunk/scripts/makedeb-climacs (contents, props changed)
trunk/scripts/makedeb-clx (contents, props changed)
trunk/scripts/makedeb-esa (contents, props changed)
trunk/scripts/makedeb-flexi-streams (contents, props changed)
trunk/scripts/makedeb-flexichain (contents, props changed)
trunk/scripts/makedeb-gsharp (contents, props changed)
trunk/scripts/makedeb-mcclim (contents, props changed)
trunk/scripts/makedeb-sbcl (contents, props changed)
trunk/scripts/makedeb-spatial-trees (contents, props changed)
trunk/scripts/makedeb-split-sequence (contents, props changed)
trunk/scripts/makedeb-tab-layout (contents, props changed)
trunk/scripts/makedeb-trivial-gray-streams (contents, props changed)
trunk/scripts/makedeb-trivial-sockets (contents, props changed)
trunk/scripts/patches/
trunk/scripts/patches/climacs.diff
Log:
initial import
Added: trunk/scripts/VERSION
==============================================================================
--- (empty file)
+++ trunk/scripts/VERSION Sun May 21 14:28:03 2006
@@ -0,0 +1 @@
+2006-05-21
Added: trunk/scripts/aux/asd
==============================================================================
--- (empty file)
+++ trunk/scripts/aux/asd Sun May 21 14:28:03 2006
@@ -0,0 +1,12 @@
+#!/bin/sh -e
+unset IFS
+if test -n "$1"; then
+ cd "$1"
+fi
+find `pwd`/ -name \*.asd | \
+ while read f; do
+ name=`basename "$f"`
+ target=`readlink -f "$f"`
+ ln -sf "$f" /opt/steeldump/lib/sbcl/site-systems/
+ echo "$name -> $f"
+ done
Added: trunk/scripts/aux/build-system
==============================================================================
--- (empty file)
+++ trunk/scripts/aux/build-system Sun May 21 14:28:03 2006
@@ -0,0 +1,19 @@
+#!/bin/sh -e
+set -x
+unset SBCL_HOME
+system=$1
+
+(
+ set +x
+ set -e
+ cd /opt/steeldump/src
+ for f in *; do
+ if test -d "$f" -a "$f" != sbcl; then
+ /opt/steeldump/scripts/aux/asd /opt/steeldump/src/$f
+ fi
+ done
+)
+/opt/steeldump/bin/sbcl \
+ --userinit /dev/null \
+ --sysinit /dev/null \
+ --load "/opt/steeldump/scripts/lisp/build-${system}.lisp"
Added: trunk/scripts/aux/fetch-cvs
==============================================================================
--- (empty file)
+++ trunk/scripts/aux/fetch-cvs Sun May 21 14:28:03 2006
@@ -0,0 +1,13 @@
+#!/bin/sh -e
+set -x
+root="$1"
+module="$2"
+rev="$3"
+
+cd /opt/steeldump/src
+if test -d "$module"; then
+ cd "$module"
+ cvs up -PAd $rev
+else
+ cvs -d "$root" co $rev "$module"
+fi
Added: trunk/scripts/aux/fetch-svn
==============================================================================
--- (empty file)
+++ trunk/scripts/aux/fetch-svn Sun May 21 14:28:03 2006
@@ -0,0 +1,13 @@
+#!/bin/sh -e
+set -x
+url="$1"
+directory="$2"
+rev="$3"
+
+cd /opt/steeldump/src
+if test -d "$directory"; then
+ cd "$directory"
+ svn up $rev
+else
+ svn co $rev $url $directory
+fi
Added: trunk/scripts/aux/fetch-url
==============================================================================
--- (empty file)
+++ trunk/scripts/aux/fetch-url Sun May 21 14:28:03 2006
@@ -0,0 +1,25 @@
+#!/bin/sh -e
+set -x
+taroptions="$1"
+urldir="$2"
+urlfile="$3"
+dir_package="$4"
+dir_wanted="$5"
+
+cd /opt/steeldump/src
+
+if test -e "$dir_package"; then
+ echo "error: $dir_package already exists, aborting"
+ exit 1
+fi
+if test -n "$dir_wanted" -a -e "$dir_wanted"; then
+ echo "error: $dir_wanted already exists, aborting"
+ exit 1
+fi
+
+# --no-check-certificate because of mgr's https
+wget --no-check-certificate -c "$urldir$urlfile"
+tar x${taroptions}f "$urlfile"
+if test -n "$dir_wanted"; then
+ mv "$dir_package" "$dir_wanted"
+fi
Added: trunk/scripts/aux/makedeb-helper
==============================================================================
--- (empty file)
+++ trunk/scripts/aux/makedeb-helper Sun May 21 14:28:03 2006
@@ -0,0 +1,35 @@
+#!/bin/sh -e
+system=$1
+
+version=`cat /opt/steeldump/scripts/VERSION`
+package=steeldump-$system
+deb=/opt/steeldump/pool/${package}_${version}_i386.deb
+
+depends="$STEELDUMP_EXTRA_DEPENDS"
+shift
+while test -n "$1"; do
+ if test -n "$depends"; then
+ depends="$depends, "
+ fi
+ depends="${depends}steeldump-$1 (= $version)"
+ shift
+done
+
+cd /opt/steeldump
+
+mkdir SCRATCH/DEBIAN
+
+cat >SCRATCH/DEBIAN/control <
+eof
+
+cat /opt/steeldump/scripts/descriptions/$system >>SCRATCH/DEBIAN/control
+
+rm -f $deb
+sudo chown -hR 0:0 SCRATCH
+dpkg-deb --build SCRATCH $deb
+sudo chown -hR --reference /opt/steeldump/scripts SCRATCH
Added: trunk/scripts/aux/wipe-fasls
==============================================================================
--- (empty file)
+++ trunk/scripts/aux/wipe-fasls Sun May 21 14:28:03 2006
@@ -0,0 +1,8 @@
+#!/bin/sh -e
+system=$1
+cd /opt/steeldump/SCRATCH/opt/steeldump/src/$system
+find . -name \*.fasl | while read fasl; do
+ echo 'pseudo .fasl to trigger recompilation' >SCRATCH.fasl
+ touch -r "$fasl" SCRATCH.fasl
+ mv SCRATCH.fasl "$fasl"
+done
Added: trunk/scripts/aux/write-dummy-asd
==============================================================================
--- (empty file)
+++ trunk/scripts/aux/write-dummy-asd Sun May 21 14:28:03 2006
@@ -0,0 +1,7 @@
+#!/bin/sh -e
+system=$1
+d=/opt/steeldump/SCRATCH/opt/steeldump/lib/sbcl/hack-systems
+mkdir -p $d
+cat >$d/$system.asd <customize-target-features.lisp <>src/runtime/runtime.h <>contrib/asdf/asdf.lisp < override
+
+dpkg-scanpackages pool override | gzip >dists/unstable/main/binary-i386/Packages.gz
+
+cat >dists/unstable/main/Release </dev/null; then
+ echo "error: cmucl not found"
+ rc=1
+fi
+if ! which dpkg-scanpackages >/dev/null; then
+ echo "error: dpkg-dev not found"
+ rc=1
+fi
+if ! which mf >/dev/null; then
+ echo "error: tetex not found"
+ rc=1
+fi
+exit $rc
Added: trunk/scripts/lisp/build-SAMPLE.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/build-SAMPLE.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,25 @@
+;;;; Replace SAMPLE in this file with the library name. Look out for
+;;;; libraries where system name, package name, and system package name
+;;;; don't agree. Often the system package is actually sample.system etc.
+;;;;
+;;;; As-is, this script not usually the the right thing for CLIM
+;;;; programs, see clim-helper.lisp for details (and build-climacs.lisp
+;;;; as an example).
+
+(sb-ext:disable-debugger)
+(setf asdf:*central-registry* (list (car asdf:*central-registry*)))
+(asdf:operate 'asdf:load-op :SAMPLE)
+
+(defmethod sb-heapdump:dump-system
+ ((c (eql (asdf:find-system :SAMPLE))))
+ (sb-heapdump:dump-packages
+ '(:SAMPLE)
+ "SAMPLE.heap"
+ :if-exists :rename-and-delete
+ :systems '(:SAMPLE)
+ :system-packages '(:SAMPLE-system)))
+
+(let ((*default-pathname-defaults*
+ (truename (sb-ext:posix-getenv "SBCL_HOME"))))
+ (sb-heapdump:dump-system :SAMPLE))
+(sb-ext:quit)
Added: trunk/scripts/lisp/build-beirc.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/build-beirc.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,20 @@
+(sb-ext:disable-debugger)
+(setf asdf:*central-registry* (list (car asdf:*central-registry*)))
+(asdf:operate 'asdf:load-op :beirc)
+
+(load "/opt/steeldump/scripts/lisp/clim-helper.lisp")
+
+(defmethod sb-heapdump:dump-system ((c (eql (asdf:find-system :beirc))))
+ (dump-clim-application
+ '(:beirc)
+ "beirc.heap"
+ nil
+ :force (list #'clim:pane)
+ :systems '(:beirc)
+ :system-packages '(:beirc.system)
+ :if-exists :rename-and-delete))
+
+(let ((*default-pathname-defaults*
+ (truename (sb-ext:posix-getenv "SBCL_HOME"))))
+ (sb-heapdump:dump-system :beirc))
+(sb-ext:quit)
Added: trunk/scripts/lisp/build-cl-fad.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/build-cl-fad.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,17 @@
+(sb-ext:disable-debugger)
+(setf asdf:*central-registry* (list (car asdf:*central-registry*)))
+(asdf:operate 'asdf:load-op :cl-fad)
+
+(defmethod sb-heapdump:dump-system
+ ((c (eql (asdf:find-system :cl-fad))))
+ (sb-heapdump:dump-packages
+ '(:cl-fad :cl-fad-test)
+ "cl-fad.heap"
+ :if-exists :rename-and-delete
+ :systems '(:cl-fad)
+ :system-packages '()))
+
+(let ((*default-pathname-defaults*
+ (truename (sb-ext:posix-getenv "SBCL_HOME"))))
+ (sb-heapdump:dump-system :cl-fad))
+(sb-ext:quit)
Added: trunk/scripts/lisp/build-cl-irc.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/build-cl-irc.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,16 @@
+(sb-ext:disable-debugger)
+(setf asdf:*central-registry* (list (car asdf:*central-registry*)))
+(asdf:operate 'asdf:load-op :cl-irc)
+
+(defmethod sb-heapdump:dump-system ((c (eql (asdf:find-system :cl-irc))))
+ (sb-heapdump:dump-packages
+ '(:cl-irc)
+ "cl-irc.heap"
+ :if-exists :rename-and-delete
+ :systems '(:cl-irc)
+ :system-packages '(:cl-irc-system)))
+
+(let ((*default-pathname-defaults*
+ (truename (sb-ext:posix-getenv "SBCL_HOME"))))
+ (sb-heapdump:dump-system :cl-irc))
+(sb-ext:quit)
Added: trunk/scripts/lisp/build-cl-ppcre.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/build-cl-ppcre.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,17 @@
+(sb-ext:disable-debugger)
+(setf asdf:*central-registry* (list (car asdf:*central-registry*)))
+(asdf:operate 'asdf:load-op :cl-ppcre)
+
+(defmethod sb-heapdump:dump-system
+ ((c (eql (asdf:find-system :cl-ppcre))))
+ (sb-heapdump:dump-packages
+ '(:cl-ppcre :cl-ppcre-test)
+ "cl-ppcre.heap"
+ :if-exists :rename-and-delete
+ :systems '(:cl-ppcre)
+ :system-packages '(:cl-ppcre.system)))
+
+(let ((*default-pathname-defaults*
+ (truename (sb-ext:posix-getenv "SBCL_HOME"))))
+ (sb-heapdump:dump-system :cl-ppcre))
+(sb-ext:quit)
Added: trunk/scripts/lisp/build-climacs.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/build-climacs.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,36 @@
+(sb-ext:disable-debugger)
+(setf asdf:*central-registry* (list (car asdf:*central-registry*)))
+
+(asdf:operate 'asdf:load-op :esa)
+(defvar *old-command-tables* (make-hash-table))
+(maphash (lambda (k v)
+ (setf (gethash k *old-command-tables*) v))
+ climi::*command-tables*)
+
+(asdf:operate 'asdf:load-op :climacs)
+(defvar *new-command-tables* (make-hash-table))
+(maphash (lambda (k v)
+ (unless (gethash k *old-command-tables*)
+ (setf (gethash k *new-command-tables*) v)))
+ climi::*command-tables*)
+
+(load "/opt/steeldump/scripts/lisp/clim-helper.lisp")
+
+(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")
+ "climacs.heap"
+ *new-command-tables*
+ :systems '(:climacs :climacs.tests)
+ :system-packages '(:climacs.system)
+ :if-exists :rename-and-delete))
+
+(let ((*default-pathname-defaults*
+ (truename (sb-ext:posix-getenv "SBCL_HOME"))))
+ (sb-heapdump:dump-system :climacs))
+(sb-ext:quit)
Added: trunk/scripts/lisp/build-clx.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/build-clx.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,36 @@
+(sb-ext:disable-debugger)
+(setf asdf:*central-registry* (list (car asdf:*central-registry*)))
+(asdf:operate 'asdf:load-op :clx)
+
+(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)))
+
+(let ((*default-pathname-defaults*
+ (truename (sb-ext:posix-getenv "SBCL_HOME"))))
+ (sb-heapdump:dump-system :clx))
+(sb-ext:quit)
Added: trunk/scripts/lisp/build-esa.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/build-esa.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,25 @@
+(sb-ext:disable-debugger)
+(setf asdf:*central-registry* (list (car asdf:*central-registry*)))
+(asdf:operate 'asdf:load-op :esa)
+
+(load "/opt/steeldump/scripts/lisp/clim-helper.lisp")
+
+(defmethod sb-heapdump:dump-system ((c (eql (asdf:find-system :esa))))
+ (dump-clim-application
+ '("ESA" "ESA-BUFFER" "ESA-IO")
+ "esa.heap"
+ nil
+ :force (list #'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 '(:esa)
+ :system-packages '()
+ :if-exists :rename-and-delete))
+
+(let ((*default-pathname-defaults*
+ (truename (sb-ext:posix-getenv "SBCL_HOME"))))
+ (sb-heapdump:dump-system :esa))
+(sb-ext:quit)
Added: trunk/scripts/lisp/build-flexi-streams.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/build-flexi-streams.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,17 @@
+(sb-ext:disable-debugger)
+(setf asdf:*central-registry* (list (car asdf:*central-registry*)))
+(asdf:operate 'asdf:load-op :flexi-streams)
+
+(defmethod sb-heapdump:dump-system
+ ((c (eql (asdf:find-system :flexi-streams))))
+ (sb-heapdump:dump-packages
+ '(:flexi-streams)
+ "flexi-streams.heap"
+ :if-exists :rename-and-delete
+ :systems '(:flexi-streams)
+ :system-packages '(:flexi-streams.system)))
+
+(let ((*default-pathname-defaults*
+ (truename (sb-ext:posix-getenv "SBCL_HOME"))))
+ (sb-heapdump:dump-system :flexi-streams))
+(sb-ext:quit)
Added: trunk/scripts/lisp/build-flexichain.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/build-flexichain.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,16 @@
+(sb-ext:disable-debugger)
+(setf asdf:*central-registry* (list (car asdf:*central-registry*)))
+(asdf:operate 'asdf:load-op :flexichain)
+
+(defmethod sb-heapdump:dump-system ((c (eql (asdf:find-system :flexichain))))
+ (sb-heapdump:dump-packages
+ (mapcar #'find-package '("FLEXICHAIN"))
+ "flexichain.heap"
+ :if-exists :rename-and-delete
+ :systems '(:flexichain)
+ :system-packages '(:flexichain-system)))
+
+(let ((*default-pathname-defaults*
+ (truename (sb-ext:posix-getenv "SBCL_HOME"))))
+ (sb-heapdump:dump-system :flexichain))
+(sb-ext:quit)
Added: trunk/scripts/lisp/build-gsharp.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/build-gsharp.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,24 @@
+(sb-ext:disable-debugger)
+(setf asdf:*central-registry* (list (car asdf:*central-registry*)))
+(asdf:operate 'asdf:load-op :gsharp)
+
+(load "/opt/steeldump/scripts/lisp/clim-helper.lisp")
+
+(defmethod sb-heapdump:dump-system ((c (eql (asdf:find-system :gsharp))))
+ (dump-clim-application
+ '("GSHARP-UTILITIES" "GF" "SDL" "SCORE-PANE" "GSHARP-BUFFER"
+ "GSHARP-NUMBERING" "OBSEQ" "GSHARP-MEASURE" "GSHARP-POSTSCRIPT"
+ "GSHARP-GLYPHS" "GSHARP-BEAMING" "GSHARP-CURSOR" "GSHARP-DRAWING"
+ "MIDI" "GSHARP-PLAY" "GSHARP")
+ "gsharp.heap"
+ nil
+ :force (list #'(setf clim:output-record-start-cursor-position)
+ #'(setf clim:output-record-end-cursor-position))
+ :systems '(:gsharp)
+ :system-packages '()
+ :if-exists :rename-and-delete))
+
+(let ((*default-pathname-defaults*
+ (truename (sb-ext:posix-getenv "SBCL_HOME"))))
+ (sb-heapdump:dump-system :gsharp))
+(sb-ext:quit)
Added: trunk/scripts/lisp/build-mcclim.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/build-mcclim.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,53 @@
+(sb-ext:disable-debugger)
+(setf asdf:*central-registry* (list (car asdf:*central-registry*)))
+(asdf:operate 'asdf:load-op :mcclim)
+(asdf:operate 'asdf:load-op :clim-examples)
+(asdf:operate 'asdf:load-op :clim-listener)
+
+(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" "CLIM-NULL" "MENUTEST"
+ "CLIM-LISTENER" "CLIM-TRANSFORMATIONS-TEST"))))
+ (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-null
+ :clim-looks :clim-clx-user :clim-examples :scigraph
+ :clim-listener)
+ :system-packages '(:mcclim.system))))
+
+(let ((*default-pathname-defaults*
+ (truename (sb-ext:posix-getenv "SBCL_HOME"))))
+ (sb-heapdump:dump-system :mcclim))
+(sb-ext:quit)
Added: trunk/scripts/lisp/build-sbcl.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/build-sbcl.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,9 @@
+(require :asdf)
+(push (merge-pathnames "site-systems/" (truename (posix-getenv "SBCL_HOME")))
+ asdf:*central-registry*)
+(require :sb-heapdump)
+(require :sb-bsd-sockets)
+(require :sb-posix)
+(require :sb-executable)
+(load "/opt/steeldump/scripts/lisp/hack-asdf.lisp")
+(save-lisp-and-die "lib/sbcl/sbcl.core")
Added: trunk/scripts/lisp/build-spatial-trees.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/build-spatial-trees.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,17 @@
+(sb-ext:disable-debugger)
+(setf asdf:*central-registry* (list (car asdf:*central-registry*)))
+(asdf:operate 'asdf:load-op :spatial-trees)
+
+(defmethod sb-heapdump:dump-system
+ ((c (eql (asdf:find-system :spatial-trees))))
+ (sb-heapdump:dump-packages
+ '(:spatial-trees :rectangles :spatial-trees-protocol :spatial-trees-impl)
+ "spatial-trees.heap"
+ :if-exists :rename-and-delete
+ :systems '(:spatial-trees)
+ :system-packages '()))
+
+(let ((*default-pathname-defaults*
+ (truename (sb-ext:posix-getenv "SBCL_HOME"))))
+ (sb-heapdump:dump-system :spatial-trees))
+(sb-ext:quit)
Added: trunk/scripts/lisp/build-split-sequence.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/build-split-sequence.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,17 @@
+(sb-ext:disable-debugger)
+(setf asdf:*central-registry* (list (car asdf:*central-registry*)))
+(asdf:operate 'asdf:load-op :split-sequence)
+
+(defmethod sb-heapdump:dump-system
+ ((c (eql (asdf:find-system :split-sequence))))
+ (sb-heapdump:dump-packages
+ '(:split-sequence)
+ "split-sequence.heap"
+ :if-exists :rename-and-delete
+ :systems '(:split-sequence)
+ :system-packages '(:split-sequence-system)))
+
+(let ((*default-pathname-defaults*
+ (truename (sb-ext:posix-getenv "SBCL_HOME"))))
+ (sb-heapdump:dump-system :split-sequence))
+(sb-ext:quit)
Added: trunk/scripts/lisp/build-tab-layout.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/build-tab-layout.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,20 @@
+(sb-ext:disable-debugger)
+(setf asdf:*central-registry* (list (car asdf:*central-registry*)))
+(asdf:operate 'asdf:load-op :tab-layout)
+
+(load "/opt/steeldump/scripts/lisp/clim-helper.lisp")
+
+(defmethod sb-heapdump:dump-system
+ ((c (eql (asdf:find-system :tab-layout))))
+ (dump-clim-application
+ '(:tab-layout :radio-layout :stack-layout)
+ "tab-layout.heap"
+ nil
+ :if-exists :rename-and-delete
+ :systems '(:tab-layout :radio-layout :stack-layout)
+ :system-packages '()))
+
+(let ((*default-pathname-defaults*
+ (truename (sb-ext:posix-getenv "SBCL_HOME"))))
+ (sb-heapdump:dump-system :tab-layout))
+(sb-ext:quit)
Added: trunk/scripts/lisp/build-trivial-gray-streams.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/build-trivial-gray-streams.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,17 @@
+(sb-ext:disable-debugger)
+(setf asdf:*central-registry* (list (car asdf:*central-registry*)))
+(asdf:operate 'asdf:load-op :trivial-gray-streams)
+
+(defmethod sb-heapdump:dump-system
+ ((c (eql (asdf:find-system :trivial-gray-streams))))
+ (sb-heapdump:dump-packages
+ '(:trivial-gray-streams)
+ "trivial-gray-streams.heap"
+ :if-exists :rename-and-delete
+ :systems '(:trivial-gray-streams)
+ :system-packages '(:trivial-gray-streams-system)))
+
+(let ((*default-pathname-defaults*
+ (truename (sb-ext:posix-getenv "SBCL_HOME"))))
+ (sb-heapdump:dump-system :trivial-gray-streams))
+(sb-ext:quit)
Added: trunk/scripts/lisp/build-trivial-sockets.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/build-trivial-sockets.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,17 @@
+(sb-ext:disable-debugger)
+(setf asdf:*central-registry* (list (car asdf:*central-registry*)))
+(asdf:operate 'asdf:load-op :trivial-sockets)
+
+(defmethod sb-heapdump:dump-system
+ ((c (eql (asdf:find-system :trivial-sockets))))
+ (sb-heapdump:dump-packages
+ '(:trivial-sockets)
+ "trivial-sockets.heap"
+ :if-exists :rename-and-delete
+ :systems '(:trivial-sockets)
+ :system-packages '(:trivial-sockets-system)))
+
+(let ((*default-pathname-defaults*
+ (truename (sb-ext:posix-getenv "SBCL_HOME"))))
+ (sb-heapdump:dump-system :trivial-sockets))
+(sb-ext:quit)
Added: trunk/scripts/lisp/clim-helper.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/clim-helper.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,117 @@
+(defun dump-clim-application
+ (packages pathname command-tables
+ &rest args &key (initializer #'identity) force &allow-other-keys)
+ (let ((p (mapcar #'find-package packages))
+ (force-specializers '()))
+ (labels
+ ((%extract-hash-table (hash-table)
+ (let ((alist '()))
+ (maphash (lambda (k v)
+ (when (or (member (symbol-package k) p)
+ (and command-tables
+ (gethash k command-tables)))
+ (when (typep v 'class)
+ (pushnew v force)
+ (pushnew (sb-kernel:find-classoid (class-name v))
+ force))
+ (let ((specializer
+ (gethash k
+ sb-pcl::*eql-specializer-table*)))
+ (when specializer
+ (pushnew specializer force-specializers)))
+ (push (cons k v) alist)))
+ hash-table)
+ alist))
+ (extract-hash-table (sym)
+ (cons sym (%extract-hash-table (symbol-value sym))))
+ (%restore-hash-table (table alist)
+ (loop for (k . v) in alist do
+ (setf (gethash k table) v)
+ (when (typep v 'class)
+ (setf (find-class (class-name v)) v))))
+ (restore-hash-table (x)
+ (%restore-hash-table (symbol-value (car x)) (cdr x)))
+ ;; climacs-specific hack to find anonymous command tables
+ ;; fixme: is this still needed?
+ (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)))
+ (restore-ptrans-data (x)
+ (loop for (name alist1 alist2) in x do
+ (let ((table (gethash name climi::*command-tables*)))
+ (when table
+ (let ((ttable (climi::presentation-translators table)))
+ (%restore-hash-table
+ (climi::translators ttable)
+ alist1)
+ (%restore-hash-table
+ (climi::simple-type-translators ttable)
+ alist2)))))
+ (incf climi::*current-translator-cache-generation*))
+ (restore-command-data (x)
+ (loop for (name . alist) in x do
+ (let ((table (gethash name climi::*command-tables*)))
+ (when table
+ (%restore-hash-table (climi::commands table) alist))))
+ (incf climi::*current-translator-cache-generation*)))
+ (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-gf-table*)
+ (extract-hash-table 'climi::*presentation-type-abbreviations*)))
+ (ptrans-data '())
+ (command-data '())
+ (forced-classes
+ (remove-if-not (lambda (x) (typep x 'class)) force)))
+ (maphash (lambda (name table)
+ (when (typep table 'clim:standard-command-table)
+ (let ((ttable (climi::presentation-translators table)))
+ (push (list name
+ (%extract-hash-table
+ (climi::translators ttable))
+ (%extract-hash-table
+ (climi::simple-type-translators ttable)))
+ ptrans-data))
+ (push (cons name
+ (%extract-hash-table (climi::commands table)))
+ command-data)))
+ climi::*command-tables*)
+ (apply #'sb-heapdump:dump-packages
+ packages
+ pathname
+ :force (cons #'dump-clim-application force)
+ :force-specializers (append force-specializers forced-classes)
+ :initializer (lambda (x)
+ (mapc #'restore-hash-table data)
+ (restore-ptrans-data ptrans-data)
+ (restore-command-data command-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)))))
Added: trunk/scripts/lisp/hack-asdf.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/hack-asdf.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,29 @@
+(in-package :sb-heapdump)
+
+(defvar *hack-systems* "/opt/steeldump/lib/sbcl/hack-systems/")
+
+(defclass module-trampoline (asdf:system) ())
+
+(defmethod asdf::traverse ((o asdf:load-op) (c module-trampoline))
+ (list (cons o c)))
+
+(defmethod asdf::traverse ((o asdf:compile-op) (c module-trampoline))
+ (error "compile-op on module-trampoline not implemented"))
+
+(defmethod asdf::perform ((o asdf:load-op) (c module-trampoline))
+ (let ((name (asdf:component-name c)))
+ (setf (gethash name asdf::*defined-systems*) nil)
+ (require name)
+ (asdf:operate 'asdf:load-op name)))
+
+(defun system-heap-file-search (name)
+ (setf name (coerce-name name))
+ (if (gethash name asdf::*defined-systems*)
+ nil
+ (let ((p (make-pathname :name name
+ :type "asd"
+ :defaults *hack-systems*)))
+ (when (probe-file p)
+ p))))
+
+(push 'system-heap-file-search asdf:*system-definition-search-functions*)
Added: trunk/scripts/lisp/relocate.lisp
==============================================================================
--- (empty file)
+++ trunk/scripts/lisp/relocate.lisp Sun May 21 14:28:03 2006
@@ -0,0 +1,2 @@
+(sb-heapdump:relocate-dumpfiles (directory "/opt/steeldump/lib/sbcl/*.heap"))
+(sb-ext:quit)
Added: trunk/scripts/makedeb-SAMPLE
==============================================================================
--- (empty file)
+++ trunk/scripts/makedeb-SAMPLE Sun May 21 14:28:03 2006
@@ -0,0 +1,18 @@
+#!/bin/sh -e
+set -x
+system=SAMPLESYSTEMNAME
+
+cd /opt/steeldump
+
+rm -rf SCRATCH
+mkdir SCRATCH
+
+tar cf - \
+ /opt/steeldump/lib/sbcl/${system}.heap \
+ /opt/steeldump/lib/sbcl/site-systems/${system}.asd \
+ /opt/steeldump/src/$system \
+ | tar C SCRATCH -xpf -
+
+/opt/steeldump/scripts/aux/wipe-fasls $system
+/opt/steeldump/scripts/aux/write-dummy-asd $system
+/opt/steeldump/scripts/aux/makedeb-helper $system sbcl DEPENDENCIES
Added: trunk/scripts/makedeb-all
==============================================================================
--- (empty file)
+++ trunk/scripts/makedeb-all Sun May 21 14:28:03 2006
@@ -0,0 +1,24 @@
+#!/bin/sh -e
+unset SBCL_HOME
+/opt/steeldump/bin/sbcl \
+ --userinit /dev/null \
+ --sysinit /dev/null \
+ --load "/opt/steeldump/scripts/lisp/relocate.lisp"
+
+/opt/steeldump/scripts/makedeb-sbcl
+/opt/steeldump/scripts/makedeb-climacs
+/opt/steeldump/scripts/makedeb-clx
+/opt/steeldump/scripts/makedeb-esa
+/opt/steeldump/scripts/makedeb-flexichain
+/opt/steeldump/scripts/makedeb-gsharp
+/opt/steeldump/scripts/makedeb-mcclim
+/opt/steeldump/scripts/makedeb-spatial-trees
+/opt/steeldump/scripts/makedeb-split-sequence
+/opt/steeldump/scripts/makedeb-cl-ppcre
+/opt/steeldump/scripts/makedeb-cl-fad
+/opt/steeldump/scripts/makedeb-tab-layout
+/opt/steeldump/scripts/makedeb-trivial-gray-streams
+/opt/steeldump/scripts/makedeb-flexi-streams
+/opt/steeldump/scripts/makedeb-trivial-sockets
+/opt/steeldump/scripts/makedeb-cl-irc
+/opt/steeldump/scripts/makedeb-beirc
Added: trunk/scripts/makedeb-beirc
==============================================================================
--- (empty file)
+++ trunk/scripts/makedeb-beirc Sun May 21 14:28:03 2006
@@ -0,0 +1,21 @@
+#!/bin/sh -e
+set -x
+system=beirc
+
+cd /opt/steeldump
+
+rm -rf SCRATCH
+mkdir SCRATCH
+
+tar cf - \
+ /opt/steeldump/lib/sbcl/${system}.heap \
+ /opt/steeldump/lib/sbcl/site-systems/${system}.asd \
+ /opt/steeldump/src/$system \
+ | tar C SCRATCH -xpf -
+
+mkdir SCRATCH/opt/steeldump/bin
+cp /opt/steeldump/scripts/data/beirc SCRATCH/opt/steeldump/bin/
+
+/opt/steeldump/scripts/aux/wipe-fasls $system
+/opt/steeldump/scripts/aux/write-dummy-asd $system
+/opt/steeldump/scripts/aux/makedeb-helper $system sbcl mcclim cl-irc split-sequence tab-layout cl-ppcre cl-fad
Added: trunk/scripts/makedeb-cl-fad
==============================================================================
--- (empty file)
+++ trunk/scripts/makedeb-cl-fad Sun May 21 14:28:03 2006
@@ -0,0 +1,18 @@
+#!/bin/sh -e
+set -x
+system=cl-fad
+
+cd /opt/steeldump
+
+rm -rf SCRATCH
+mkdir SCRATCH
+
+tar cf - \
+ /opt/steeldump/lib/sbcl/${system}.heap \
+ /opt/steeldump/lib/sbcl/site-systems/${system}.asd \
+ /opt/steeldump/src/$system \
+ | tar C SCRATCH -xpf -
+
+/opt/steeldump/scripts/aux/wipe-fasls $system
+/opt/steeldump/scripts/aux/write-dummy-asd $system
+/opt/steeldump/scripts/aux/makedeb-helper $system sbcl
Added: trunk/scripts/makedeb-cl-irc
==============================================================================
--- (empty file)
+++ trunk/scripts/makedeb-cl-irc Sun May 21 14:28:03 2006
@@ -0,0 +1,18 @@
+#!/bin/sh -e
+set -x
+system=cl-irc
+
+cd /opt/steeldump
+
+rm -rf SCRATCH
+mkdir SCRATCH
+
+tar cf - \
+ /opt/steeldump/lib/sbcl/${system}.heap \
+ /opt/steeldump/lib/sbcl/site-systems/${system}.asd \
+ /opt/steeldump/src/$system \
+ | tar C SCRATCH -xpf -
+
+/opt/steeldump/scripts/aux/wipe-fasls $system
+/opt/steeldump/scripts/aux/write-dummy-asd $system
+/opt/steeldump/scripts/aux/makedeb-helper $system sbcl split-sequence trivial-sockets flexi-streams
Added: trunk/scripts/makedeb-cl-ppcre
==============================================================================
--- (empty file)
+++ trunk/scripts/makedeb-cl-ppcre Sun May 21 14:28:03 2006
@@ -0,0 +1,18 @@
+#!/bin/sh -e
+set -x
+system=cl-ppcre
+
+cd /opt/steeldump
+
+rm -rf SCRATCH
+mkdir SCRATCH
+
+tar cf - \
+ /opt/steeldump/lib/sbcl/${system}.heap \
+ /opt/steeldump/lib/sbcl/site-systems/${system}.asd \
+ /opt/steeldump/src/$system \
+ | tar C SCRATCH -xpf -
+
+/opt/steeldump/scripts/aux/wipe-fasls $system
+/opt/steeldump/scripts/aux/write-dummy-asd $system
+/opt/steeldump/scripts/aux/makedeb-helper $system sbcl
Added: trunk/scripts/makedeb-climacs
==============================================================================
--- (empty file)
+++ trunk/scripts/makedeb-climacs Sun May 21 14:28:03 2006
@@ -0,0 +1,21 @@
+#!/bin/sh -e
+set -x
+system=climacs
+
+cd /opt/steeldump
+
+rm -rf SCRATCH
+mkdir SCRATCH
+
+tar cf - \
+ /opt/steeldump/lib/sbcl/${system}.heap \
+ /opt/steeldump/lib/sbcl/site-systems/${system}.asd \
+ /opt/steeldump/src/$system \
+ | tar C SCRATCH -xpf -
+
+mkdir SCRATCH/opt/steeldump/bin
+cp /opt/steeldump/scripts/data/climacs SCRATCH/opt/steeldump/bin/
+
+/opt/steeldump/scripts/aux/wipe-fasls $system
+/opt/steeldump/scripts/aux/write-dummy-asd $system
+/opt/steeldump/scripts/aux/makedeb-helper $system sbcl mcclim flexichain esa split-sequence
Added: trunk/scripts/makedeb-clx
==============================================================================
--- (empty file)
+++ trunk/scripts/makedeb-clx Sun May 21 14:28:03 2006
@@ -0,0 +1,18 @@
+#!/bin/sh -e
+set -x
+system=clx
+
+cd /opt/steeldump
+
+rm -rf SCRATCH
+mkdir SCRATCH
+
+tar cf - \
+ /opt/steeldump/lib/sbcl/${system}.heap \
+ /opt/steeldump/lib/sbcl/site-systems/${system}.asd \
+ /opt/steeldump/src/$system \
+ | tar C SCRATCH -xpf -
+
+/opt/steeldump/scripts/aux/wipe-fasls $system
+/opt/steeldump/scripts/aux/write-dummy-asd $system
+/opt/steeldump/scripts/aux/makedeb-helper $system sbcl
Added: trunk/scripts/makedeb-esa
==============================================================================
--- (empty file)
+++ trunk/scripts/makedeb-esa Sun May 21 14:28:03 2006
@@ -0,0 +1,18 @@
+#!/bin/sh -e
+set -x
+system=esa
+
+cd /opt/steeldump
+
+rm -rf SCRATCH
+mkdir SCRATCH
+
+tar cf - \
+ /opt/steeldump/lib/sbcl/${system}.heap \
+ /opt/steeldump/lib/sbcl/site-systems/${system}.asd \
+ /opt/steeldump/src/$system \
+ | tar C SCRATCH -xpf -
+
+/opt/steeldump/scripts/aux/wipe-fasls $system
+/opt/steeldump/scripts/aux/write-dummy-asd $system
+/opt/steeldump/scripts/aux/makedeb-helper $system sbcl mcclim
Added: trunk/scripts/makedeb-flexi-streams
==============================================================================
--- (empty file)
+++ trunk/scripts/makedeb-flexi-streams Sun May 21 14:28:03 2006
@@ -0,0 +1,18 @@
+#!/bin/sh -e
+set -x
+system=flexi-streams
+
+cd /opt/steeldump
+
+rm -rf SCRATCH
+mkdir SCRATCH
+
+tar cf - \
+ /opt/steeldump/lib/sbcl/${system}.heap \
+ /opt/steeldump/lib/sbcl/site-systems/${system}.asd \
+ /opt/steeldump/src/$system \
+ | tar C SCRATCH -xpf -
+
+/opt/steeldump/scripts/aux/wipe-fasls $system
+/opt/steeldump/scripts/aux/write-dummy-asd $system
+/opt/steeldump/scripts/aux/makedeb-helper $system sbcl trivial-gray-streams
Added: trunk/scripts/makedeb-flexichain
==============================================================================
--- (empty file)
+++ trunk/scripts/makedeb-flexichain Sun May 21 14:28:03 2006
@@ -0,0 +1,18 @@
+#!/bin/sh -e
+set -x
+system=flexichain
+
+cd /opt/steeldump
+
+rm -rf SCRATCH
+mkdir SCRATCH
+
+tar cf - \
+ /opt/steeldump/lib/sbcl/${system}.heap \
+ /opt/steeldump/lib/sbcl/site-systems/${system}.asd \
+ /opt/steeldump/src/$system \
+ | tar C SCRATCH -xpf -
+
+/opt/steeldump/scripts/aux/wipe-fasls $system
+/opt/steeldump/scripts/aux/write-dummy-asd $system
+/opt/steeldump/scripts/aux/makedeb-helper $system sbcl
Added: trunk/scripts/makedeb-gsharp
==============================================================================
--- (empty file)
+++ trunk/scripts/makedeb-gsharp Sun May 21 14:28:03 2006
@@ -0,0 +1,21 @@
+#!/bin/sh -e
+set -x
+system=gsharp
+
+cd /opt/steeldump
+
+rm -rf SCRATCH
+mkdir SCRATCH
+
+tar cf - \
+ /opt/steeldump/lib/sbcl/${system}.heap \
+ /opt/steeldump/lib/sbcl/site-systems/${system}.asd \
+ /opt/steeldump/src/$system \
+ | tar C SCRATCH -xpf -
+
+mkdir SCRATCH/opt/steeldump/bin
+cp /opt/steeldump/scripts/data/gsharp SCRATCH/opt/steeldump/bin/gsharp
+
+/opt/steeldump/scripts/aux/wipe-fasls $system
+/opt/steeldump/scripts/aux/write-dummy-asd $system
+/opt/steeldump/scripts/aux/makedeb-helper $system sbcl mcclim flexichain esa
Added: trunk/scripts/makedeb-mcclim
==============================================================================
--- (empty file)
+++ trunk/scripts/makedeb-mcclim Sun May 21 14:28:03 2006
@@ -0,0 +1,21 @@
+#!/bin/sh -e
+set -x
+system=mcclim
+
+cd /opt/steeldump
+
+rm -rf SCRATCH
+mkdir SCRATCH
+
+tar cf - \
+ /opt/steeldump/lib/sbcl/${system}.heap \
+ /opt/steeldump/lib/sbcl/site-systems/${system}.asd \
+ /opt/steeldump/src/$system \
+ | tar C SCRATCH -xpf -
+
+mkdir SCRATCH/opt/steeldump/bin
+cp /opt/steeldump/scripts/data/clim-listener SCRATCH/opt/steeldump/bin/
+
+/opt/steeldump/scripts/aux/wipe-fasls $system
+/opt/steeldump/scripts/aux/write-dummy-asd $system
+/opt/steeldump/scripts/aux/makedeb-helper $system sbcl clx spatial-trees
Added: trunk/scripts/makedeb-sbcl
==============================================================================
--- (empty file)
+++ trunk/scripts/makedeb-sbcl Sun May 21 14:28:03 2006
@@ -0,0 +1,20 @@
+#!/bin/sh -e
+set -x
+package=steeldump-sbcl
+version=2006-05-01
+deb=/opt/steeldump/pool/${package}_${version}_i386.deb
+
+cd /opt/steeldump
+
+rm -rf SCRATCH
+mkdir SCRATCH
+
+tar --exclude=\*.heap --exclude=site-systems/\*.asd -cf - \
+ /opt/steeldump/bin/sbcl \
+ /opt/steeldump/lib/sbcl \
+ /opt/steeldump/share/man/man1/sbcl.1 \
+ /opt/steeldump/share/doc/sbcl \
+ | tar C SCRATCH -xpf -
+
+STEELDUMP_EXTRA_DEPENDS="libc6 (>= 2.3.5-1)" \
+/opt/steeldump/scripts/aux/makedeb-helper sbcl
Added: trunk/scripts/makedeb-spatial-trees
==============================================================================
--- (empty file)
+++ trunk/scripts/makedeb-spatial-trees Sun May 21 14:28:03 2006
@@ -0,0 +1,18 @@
+#!/bin/sh -e
+set -x
+system=spatial-trees
+
+cd /opt/steeldump
+
+rm -rf SCRATCH
+mkdir SCRATCH
+
+tar cf - \
+ /opt/steeldump/lib/sbcl/${system}.heap \
+ /opt/steeldump/lib/sbcl/site-systems/${system}.asd \
+ /opt/steeldump/src/$system \
+ | tar C SCRATCH -xpf -
+
+/opt/steeldump/scripts/aux/wipe-fasls $system
+/opt/steeldump/scripts/aux/write-dummy-asd $system
+/opt/steeldump/scripts/aux/makedeb-helper $system sbcl
Added: trunk/scripts/makedeb-split-sequence
==============================================================================
--- (empty file)
+++ trunk/scripts/makedeb-split-sequence Sun May 21 14:28:03 2006
@@ -0,0 +1,18 @@
+#!/bin/sh -e
+set -x
+system=split-sequence
+
+cd /opt/steeldump
+
+rm -rf SCRATCH
+mkdir SCRATCH
+
+tar cf - \
+ /opt/steeldump/lib/sbcl/${system}.heap \
+ /opt/steeldump/lib/sbcl/site-systems/${system}.asd \
+ /opt/steeldump/src/$system \
+ | tar C SCRATCH -xpf -
+
+/opt/steeldump/scripts/aux/wipe-fasls $system
+/opt/steeldump/scripts/aux/write-dummy-asd $system
+/opt/steeldump/scripts/aux/makedeb-helper $system sbcl
Added: trunk/scripts/makedeb-tab-layout
==============================================================================
--- (empty file)
+++ trunk/scripts/makedeb-tab-layout Sun May 21 14:28:03 2006
@@ -0,0 +1,18 @@
+#!/bin/sh -e
+set -x
+system=tab-layout
+
+cd /opt/steeldump
+
+rm -rf SCRATCH
+mkdir SCRATCH
+
+tar cf - \
+ /opt/steeldump/lib/sbcl/${system}.heap \
+ /opt/steeldump/lib/sbcl/site-systems/${system}.asd \
+ /opt/steeldump/src/$system \
+ | tar C SCRATCH -xpf -
+
+/opt/steeldump/scripts/aux/wipe-fasls $system
+/opt/steeldump/scripts/aux/write-dummy-asd $system
+/opt/steeldump/scripts/aux/makedeb-helper $system sbcl mcclim
Added: trunk/scripts/makedeb-trivial-gray-streams
==============================================================================
--- (empty file)
+++ trunk/scripts/makedeb-trivial-gray-streams Sun May 21 14:28:03 2006
@@ -0,0 +1,18 @@
+#!/bin/sh -e
+set -x
+system=trivial-gray-streams
+
+cd /opt/steeldump
+
+rm -rf SCRATCH
+mkdir SCRATCH
+
+tar cf - \
+ /opt/steeldump/lib/sbcl/${system}.heap \
+ /opt/steeldump/lib/sbcl/site-systems/${system}.asd \
+ /opt/steeldump/src/$system \
+ | tar C SCRATCH -xpf -
+
+/opt/steeldump/scripts/aux/wipe-fasls $system
+/opt/steeldump/scripts/aux/write-dummy-asd $system
+/opt/steeldump/scripts/aux/makedeb-helper $system sbcl mcclim
Added: trunk/scripts/makedeb-trivial-sockets
==============================================================================
--- (empty file)
+++ trunk/scripts/makedeb-trivial-sockets Sun May 21 14:28:03 2006
@@ -0,0 +1,18 @@
+#!/bin/sh -e
+set -x
+system=trivial-sockets
+
+cd /opt/steeldump
+
+rm -rf SCRATCH
+mkdir SCRATCH
+
+tar cf - \
+ /opt/steeldump/lib/sbcl/${system}.heap \
+ /opt/steeldump/lib/sbcl/site-systems/${system}.asd \
+ /opt/steeldump/src/$system \
+ | tar C SCRATCH -xpf -
+
+/opt/steeldump/scripts/aux/wipe-fasls $system
+/opt/steeldump/scripts/aux/write-dummy-asd $system
+/opt/steeldump/scripts/aux/makedeb-helper $system sbcl mcclim
Added: trunk/scripts/patches/climacs.diff
==============================================================================
--- (empty file)
+++ trunk/scripts/patches/climacs.diff Sun May 21 14:28:03 2006
@@ -0,0 +1,15 @@
+Index: packages.lisp
+===================================================================
+RCS file: /project/climacs/cvsroot/climacs/packages.lisp,v
+retrieving revision 1.96
+diff -u -u -r1.96 packages.lisp
+--- packages.lisp 14 May 2006 20:35:44 -0000 1.96
++++ packages.lisp 21 May 2006 14:54:58 -0000
+@@ -204,6 +204,7 @@
+ (defpackage :climacs-lisp-syntax
+ (:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base
+ :climacs-syntax :flexichain :climacs-pane :climacs-gui)
++ (:shadow :form)
+ (:export :lisp-string))
+
+
From dlichteblau at common-lisp.net Sun May 21 18:31:58 2006
From: dlichteblau at common-lisp.net (dlichteblau at common-lisp.net)
Date: Sun, 21 May 2006 14:31:58 -0400 (EDT)
Subject: [steeldump-cvs] r3 - in trunk: sb-heapdump sb-heapdump/CVS scripts
Message-ID: <20060521183158.A2DFE5919E@common-lisp.net>
Author: dlichteblau
Date: Sun May 21 14:31:55 2006
New Revision: 3
Added:
trunk/sb-heapdump/
trunk/sb-heapdump/CVS/
trunk/sb-heapdump/CVS/Entries
trunk/sb-heapdump/CVS/Repository
trunk/sb-heapdump/CVS/Root
trunk/sb-heapdump/Makefile
trunk/sb-heapdump/NEWS
trunk/sb-heapdump/common.lisp
trunk/sb-heapdump/demo.lisp
trunk/sb-heapdump/dump.lisp
trunk/sb-heapdump/generation.h
trunk/sb-heapdump/load.lisp
trunk/sb-heapdump/module.lisp
trunk/sb-heapdump/pack.lisp
trunk/sb-heapdump/package.lisp
trunk/sb-heapdump/patch.lisp
trunk/sb-heapdump/relocate.c
trunk/sb-heapdump/sb-heapdump.asd
trunk/sb-heapdump/sb-heapdump.texinfo
trunk/sb-heapdump/test.lisp
trunk/sb-heapdump/testpack.lisp
trunk/sb-heapdump/trampoline.c
Modified:
trunk/scripts/fetch-sbcl
Log:
mirror of private sb-heapdump repository
Added: trunk/sb-heapdump/CVS/Entries
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/CVS/Entries Sun May 21 14:31:55 2006
@@ -0,0 +1,18 @@
+/Makefile/1.1/Sun Jan 22 15:42:49 2006//
+/NEWS/1.9/Thu Feb 2 17:41:48 2006//
+/common.lisp/1.23/Tue Jan 31 20:33:09 2006//
+/demo.lisp/1.31/Sun May 21 12:35:09 2006//
+/dump.lisp/1.62/Wed Apr 26 20:13:23 2006//
+/generation.h/1.2/Sun Jan 22 16:39:15 2006//
+/load.lisp/1.47/Wed Apr 26 20:13:24 2006//
+/module.lisp/1.6/Thu Feb 2 22:26:27 2006//
+/pack.lisp/1.23/Sun May 21 13:15:48 2006//
+/package.lisp/1.10/Sun Jan 22 16:39:15 2006//
+/patch.lisp/1.2/Thu Feb 2 16:04:23 2006//
+/relocate.c/1.18/Wed Apr 26 20:13:24 2006//
+/sb-heapdump.asd/1.10/Tue Jan 31 20:33:09 2006//
+/sb-heapdump.texinfo/1.8/Thu Feb 2 22:26:27 2006//
+/test.lisp/1.26/Tue Jan 31 20:33:09 2006//
+/testpack.lisp/1.4/Sun Jan 22 20:30:20 2006//
+/trampoline.c/1.4/Tue Jan 31 20:33:09 2006//
+D
Added: trunk/sb-heapdump/CVS/Repository
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/CVS/Repository Sun May 21 14:31:55 2006
@@ -0,0 +1 @@
+sb-heapdump
Added: trunk/sb-heapdump/CVS/Root
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/CVS/Root Sun May 21 14:31:55 2006
@@ -0,0 +1 @@
+/home/david/cvsroot
Added: trunk/sb-heapdump/Makefile
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/Makefile Sun May 21 14:31:55 2006
@@ -0,0 +1,16 @@
+CFLAGS=-I../../src/runtime/ -Wall -O2
+EXTRA_ALL_TARGETS=it
+
+SYSTEM=sb-heapdump
+include ../asdf-module.mk
+
+it: trampoline relocate.so
+
+relocate.so: relocate.o
+ gcc -shared -o $@ $^
+
+trampoline: trampoline.o
+ gcc -o $@ $^ -lm
+
+%.o: %.c
+ gcc $(CFLAGS) -c -fPIC -o $@ $<
Added: trunk/sb-heapdump/NEWS
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/NEWS Sun May 21 14:31:55 2006
@@ -0,0 +1,27 @@
+Changes in sb-heapdump-05
+ * x86-64 fixes
+ * PowerPC/cheneygc port
+ * alien fixups
+
+Changes in sb-heapdump-04
+ * s/:supersede/:rename-and-delete/, because SBCL does not, as the spec
+ says, create a *new* file under the old name, but rather overwrites
+ the data in the old file using O_TRUNC! Not a good idea when the
+ file in question is currently mapped into dynamic space!
+ * convenience function DUMP-SYSTEM for ASDF systems
+ * MAKE-EXECUTABLE hack
+ * allow .heap files to be concatenated
+ * don't duplicate SB-IMPL::*PHYSICAL-HOST*
+
+Changes in sb-heapdump-03
+ * support for SAPs
+ * support for weak pointers
+ * avoid recomputing gf dfuns multiple times
+ * mark hash tables for rehashing if a hash value is eq-based
+ * keep an explicit worklist to avoid overflowing the stack for deep graphs
+ * fixed CTORs (ensure-ctor sometimes returns NIL...)
+ * user fixups; removed :PARAMETERS in favour of :CUSTOMIZER
+ * new howto: climacs
+ * relocate heap files manually instead of relying on GC, eliminating
+ the need for a patch to SBCL and allowing files to be mapped without
+ any relocation if the targeted space is free.
Added: trunk/sb-heapdump/common.lisp
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/common.lisp Sun May 21 14:31:55 2006
@@ -0,0 +1,71 @@
+;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; Copyright (c) 2006 David Lichteblau
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation files
+;;; (the "Software"), to deal in the Software without restriction,
+;;; including without limitation the rights to use, copy, modify, merge,
+;;; publish, distribute, sublicense, and/or sell copies of the Software,
+;;; and to permit persons to whom the Software is furnished to do so,
+;;; subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;;; SOFTWARE.
+
+(in-package :sb-heapdump)
+
+(defconstant +n+ sb-vm:n-word-bytes)
+(defconstant +2n+ (* 2 +n+))
+
+(defstruct (header (:type vector))
+ object
+ fixups
+ initializer
+ customizer)
+
+(macrolet ((doit (&rest names)
+ `(progn
+ (defvar *fixup-names* ,(coerce names 'vector))
+ ,@(loop
+ for name in names
+ for i from 0
+ collect `(defconstant ,name ,i)))))
+ ;; order matters
+ (doit +package-fixup+
+ +symbol-fixup+
+ +classoid-fixup+
+ +layout-fixup+
+ +fdefn-fixup+
+ +named-type-fixup+
+ +array-type-fixup+
+ +class-fixup+
+ +function-fixup+
+ +ctor-fixup+
+ +slot-accessor-fixup+
+ +fast-method-fixup+
+ +raw-address-fixup+
+ +variable-fixup+
+ +foreign-fixup+
+ +user-fixup+))
+
+(defstruct (fixup
+ (:type vector)
+ (:constructor make-fixup (type id))
+ (:constructor make-symbol-fixup (type id2 id))
+ (:constructor make-fast-method-fixup (type id id2))
+ (:constructor make-foreign-fixup (type id id2))
+ (:constructor make-user-fixup (type id id2)))
+ type
+ id
+ id2
+ locations)
Added: trunk/sb-heapdump/demo.lisp
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/demo.lisp Sun May 21 14:31:55 2006
@@ -0,0 +1,236 @@
+;;; -*- indent-tabs-mode: nil -*-
+
+;;; Sample DUMP-SYSTEM implementations for some ASDF systems
+
+;;; FIXME: To dump a system defining generic functions (like McCLIM)
+;;; that a different system adds methods to (like Climacs), make sure to
+;;; dump the former system before loading the latter.
+;;;
+;;; Otherwise there will be unresolvable references to Climacs functions
+;;; in the dumpfile for McCLIM.
+
+
+(defmethod sb-heapdump:dump-system ((c (eql (asdf:find-system :xmls))))
+ (sb-heapdump:dump-packages :xmls "xmls.heap" :if-exists :rename-and-delete))
+
+
+(defmethod sb-heapdump:dump-system ((c (eql (asdf:find-system :cxml))))
+ (sb-heapdump:dump-packages
+ '("RUNE-DOM" "RUNES" "RUNES-ENCODING" "UTF8-RUNES" "CXML" "SAX" "DOM"
+ "UTF8-DOM" "CXML-XMLS" "DOMTEST" "XMLCONF" "DOMTEST-TESTS")
+ "test.heap"
+ :if-exists :rename-and-delete
+ :systems '(:cxml-runes :cxml-xml :cxml-dom :cxml-test :cxml)
+ :system-packages '(:cxml-system)))
+
+
+(defmethod sb-heapdump:dump-system ((c (eql (asdf:find-system :clx))))
+ (sb-heapdump:dump-packages
+ ;; The test stuff is apparently loaded only when compiling clx for the
+ ;; first time (and must then be dumped, too), not when loading clx later(?).
+ ;; Let's just ignore the non-existent package for now.
+ (remove nil (mapcar #'find-package '(:gl :glx :xlib :clipboard :gl-test)))
+ "clx.heap"
+ :if-exists :rename-and-delete
+ :initializer (let ((event-keys xlib::*event-key-vector*))
+ (lambda (packages)
+ (loop
+ for event-key across event-keys
+ for i from 0
+ do
+ (setf (get event-key 'xlib::event-code) i))
+ (setf *features*
+ (union *features*
+ '(:clx-ext-render
+ :clx-mit-r5
+ :clx-mit-r4
+ :xlib
+ :clx
+ :clx-little-endian
+ :clx-ansi-common-lisp)))
+ packages))
+ :systems '(:clx)
+ :system-packages '(:clx-system)))
+
+#|
+(load "/home/david/src/lisp/clx_0.7.1/demo/menu")
+(xlib::just-say-lisp)
+|#
+
+(defmethod sb-heapdump:dump-system ((c (eql (asdf:find-system :mcclim))))
+ (let ((packages
+ (mapcar #'find-package
+ '("IMAGE" "CLIM-CLX" "CLIM-XCOMMON" "CLIM-POSTSCRIPT"
+ "CLIM-FFI" "GOATEE" "CLIM-USER" "CLIM-DEMO"
+ "CLIM-INTERNALS" "CLIM-BACKEND" "CLIM-EXTENSIONS"
+ "CLIM-SYS" "CLIM" "CLIM-LISP" "CLIM-MOP"
+ "CLIM-LISP-PATCH"))))
+ (sb-heapdump:dump-packages
+ packages
+ "mcclim.heap"
+ :if-exists :rename-and-delete
+ ;; Pfui, dagegen ist CLX ja noch brav und benutzt einen Indicator
+ ;; aus seinem eigenen Paket.
+ :initializer (let* ((ports climi::*server-path-search-order*)
+ (types
+ (loop
+ for port in ports
+ collect (get port :port-type)))
+ (parsers
+ (loop
+ for port in ports
+ collect (get port :server-path-parser))))
+ (lambda (x)
+ (loop
+ for port in ports
+ for type in types
+ for parser in parsers
+ do
+ (setf (get port :port-type) type)
+ (setf (get port :server-path-parser) parser))
+ (pushnew :clim *features*)
+ (pushnew :mcclim *features*)
+ x))
+ :systems '(:mcclim :clim :clim-lisp :clim-core :goatee-core
+ :clim-postscript :clim-clx :clim-opengl
+ :clim-objc-support :clim-beagle :clim-looks
+ :clim-clx-user :clim-examples :scigraph
+ :clim-listener)
+ :system-packages '(:mcclim.system))))
+
+
+(defun dump-clim-application
+ (packages pathname
+ &rest args &key (initializer #'identity) force &allow-other-keys)
+ (let ((p (mapcar #'find-package packages)))
+ (flet ((extract-hash-table (sym)
+ (let ((hash-table (symbol-value sym))
+ (alist '()))
+ (maphash (lambda (k v)
+ (when (member (symbol-package k) p)
+ (when (typep v 'class)
+ (pushnew (class-name v) force))
+ (push (cons k v) alist)))
+ hash-table)
+ (cons sym alist)))
+ (restore-hash-table (x)
+ (let ((table (symbol-value (car x))))
+ (loop for (k . v) in (cdr x) do (setf (gethash k table) v))))
+ ;; climacs-specific hack to find anonymous command tables
+ (extract-climacs-tables (sym)
+ (let ((hash-table (symbol-value sym))
+ (anonymous-command-tables '())
+ (alist '()))
+ (maphash (lambda (k v)
+ (when (member (symbol-package k) p)
+ (dolist (mi (slot-value v 'climi::keystroke-items))
+ (pushnew (clim:command-menu-item-value
+ (clim:menu-item-value mi))
+ anonymous-command-tables))))
+ hash-table)
+ (dolist (name anonymous-command-tables)
+ (push (cons name (gethash name hash-table)) alist))
+ (cons sym alist))))
+ (let ((data
+ (list
+ (extract-hash-table 'climi::*command-tables*)
+ (extract-climacs-tables 'climi::*command-tables*)
+ (extract-hash-table 'climi::*command-parser-table*)
+ (extract-hash-table 'climi::*presentation-type-table*)
+ (extract-hash-table 'climi::*presentation-type-abbreviations*))))
+ (apply #'sb-heapdump:dump-packages
+ packages
+ pathname
+ :force (cons #'dump-clim-application force)
+ :initializer (lambda (x)
+ (mapc #'restore-hash-table data)
+ (funcall initializer x))
+ ;; CLIM wants the +foo-ink+s to be unique objects.
+ :customizer (lambda (object)
+ (dolist (var '(climi::*unsupplied-argument-marker*
+ climi::*numeric-argument-marker*
+ clim:+foreground-ink+
+ clim:+foreground-ink+
+ clim:+background-ink+
+ clim:+flipping-ink+)
+ t)
+ (when (eq object (symbol-value var))
+ (return (values :fixup var)))))
+ :load-time-customizer (lambda (sym ignore)
+ ignore
+ (symbol-value sym))
+ args)))))
+
+(defmethod sb-heapdump:dump-system ((c (eql (asdf:find-system :climacs))))
+ (dump-clim-application
+ '("CLIMACS-SLIDEMACS-EDITOR" "CLIMACS-TTCN3-SYNTAX" "CLIMACS-GUI" "ESA"
+ "CLIMACS-LISP-SYNTAX" "CLIMACS-CL-SYNTAX" "CLIMACS-PROLOG-SYNTAX"
+ "CLIMACS-HTML-SYNTAX" "CLIMACS-FUNDAMENTAL-SYNTAX" "CLIMACS-PANE" "UNDO"
+ "CLIMACS-KILL-RING" "CLIMACS-SYNTAX" "CLIMACS-ABBREV" "CLIMACS-BASE"
+ "CLIMACS-BUFFER" "BINSEQ" "AUTOMATON" "EQV-HASH" "FLEXICHAIN")
+ "climacs.heap"
+ :force (list 'clim:form #'clim:command-table #'(setf clim:command-table))
+ :initializer (lambda (x)
+ (setf (fdefinition 'clim:command-table) #'clim:command-table)
+ (setf (fdefinition '(setf clim:command-table))
+ #'(setf clim:command-table))
+ x)
+ :systems '(:climacs :climacs.tests :flexichain)
+ :system-packages '(:climacs.system :flexichain-system)
+ :if-exists :rename-and-delete))
+
+#|
+(sb-heapdump:relocate-dumpfiles '("clx.heap" "mcclim.heap" "climacs.heap"))
+(sb-heapdump:make-executable "climacs.heap":main-function 'climacs-gui:climacs)
+|#
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; simple DUMP-OBJECT tests
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+#|
+
+(sb-heapdump::dump-object (let ((x (make-hash-table)))
+ (setf (gethash 'foo x) 'bar)
+ x)
+ "test.heap"
+ :if-exists :rename-and-delete)
+
+(sb-heapdump::dump-object (lambda ())
+ "test.heap"
+ :if-exists :rename-and-delete)
+
+(defun ff (x) (if (zerop x) 1 (* x (ff (1- x)))))
+
+(sb-heapdump::dump-object
+ #'ff
+ "test.heap"
+ :force t
+ :if-exists :rename-and-delete)
+
+(sb-heapdump::dump-object
+ '("foo" "bar")
+ "test.heap"
+ :force t
+ :if-exists :rename-and-delete)
+
+(sb-heapdump::dump-object
+ (list (sb-ext:make-weak-pointer :foo))
+ "test.heap"
+ :force t
+ :if-exists :rename-and-delete)
+
+(sb-heapdump::dump-object
+ '("foo" "bar")
+ "test.heap"
+ :initializer #'print
+ :if-exists :rename-and-delete)
+
+(sb-heapdump::dump-object
+ '("baz" "quux")
+ "test.heap"
+ :initializer #'print
+ :if-exists :append)
+
+|#
Added: trunk/sb-heapdump/dump.lisp
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/dump.lisp Sun May 21 14:31:55 2006
@@ -0,0 +1,794 @@
+;;; -*- indent-tabs-mode: nil -*-
+
+;;; Copyright (c) 2006 David Lichteblau
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation files
+;;; (the "Software"), to deal in the Software without restriction,
+;;; including without limitation the rights to use, copy, modify, merge,
+;;; publish, distribute, sublicense, and/or sell copies of the Software,
+;;; and to permit persons to whom the Software is furnished to do so,
+;;; subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;;; SOFTWARE.
+
+(in-package :sb-heapdump)
+
+(sb-alien:define-alien-variable "sizetab" (array (* t) 256))
+
+(defconstant +page-size+
+ #+gencgc sb-vm:gencgc-page-size
+ #-gencgc sb-c:*backend-page-size*)
+
+(defvar *default-base-address*
+ #+gencgc
+ ;; by default, target the center of dynamic space
+ (logandc2 (/ (+ sb-vm:dynamic-space-start sb-vm:dynamic-space-end) 2)
+ (1- +page-size+))
+ #-gencgc
+ ;; will always relocate anyway
+ sb-vm:dynamic-0-space-start)
+
+(defvar *dump-verbose* t)
+(defvar *dump-print* nil)
+
+(defstruct
+ (ctx (:constructor make-ctx (stream stream-start base-address customizer
+ &key (worklist (cons nil nil))
+ (worklist-tail worklist))))
+ stream
+ stream-start
+ base-address
+ (position (* 3 +n+)) ;base address, length, header pointer
+ (fixups '())
+ (force (make-hash-table))
+ customizer
+ (addresses (make-hash-table))
+ (weak-pointers '())
+ (worklist (error "oops"))
+ (worklist-tail (error "oops")))
+
+(defvar *disable-customizer* nil)
+(defconstant +invalid+ 0)
+
+(defun dump-object
+ (object pathname &key (if-exists :error)
+ customizer
+ load-time-customizer
+ force
+ initializer
+ (base-address *default-base-address*)
+ (print-statistics *dump-print*))
+ (when (eq if-exists :supersede)
+ ;; Argh! SBCL implements :supersede as O_TRUNC, even though the Hypersec
+ ;; says explicitly to create a *new* file under the same name instead
+ ;; of overwriting the old one.
+ (setf if-exists :rename-and-delete))
+ (with-open-file (s pathname
+ :direction :output
+ :element-type '(unsigned-byte 8)
+ ;; Argh! SBCL implements :append as O_APPEND, even though
+ ;; the Hyperspec says to position the file pointer at
+ ;; the end of the file *initially*.
+ :if-exists (if (eq if-exists :append) :overwrite if-exists))
+ (when (eq if-exists :append)
+ (file-position s (file-length s)))
+ (let ((ctx (make-ctx s (file-position s) base-address customizer)))
+ (dolist (arg (if (eq force t) (list object) force))
+ (setf (gethash arg (ctx-force ctx)) t))
+ (dump-all object ctx)
+ ;; kludge: wrap the functions in conses, since the header is written
+ ;; after the fixups and cannot itself contain fixups.
+ (when initializer
+ (setf initializer (list initializer))
+ (dump-all initializer ctx))
+ (when load-time-customizer
+ (setf load-time-customizer (list load-time-customizer))
+ (dump-all load-time-customizer ctx))
+ (update-weak-pointers ctx)
+ (unless (integerp (gethash object (ctx-addresses ctx)))
+ (error "argument was replaced by a fixup.~_ Use :FORCE to dump ~
+ this object literally:~_ ~A"
+ object))
+ (let ((*disable-customizer* t))
+ (dump-fixups ctx)
+ (let* ((header
+ (make-header :object object
+ :fixups (ctx-fixups ctx)
+ :customizer load-time-customizer
+ :initializer initializer))
+ (header-address (dump-all header ctx))
+ (file-length (progn (finish-output s) (file-length s)))
+ (length (- file-length (ctx-stream-start ctx)))
+ (padding (- (nth-value 1 (ceiling length +page-size+)))))
+ (file-position s file-length)
+ (dotimes (x padding)
+ (write-byte 0 s))
+ (seek ctx 0)
+ (write-word base-address ctx)
+ (write-word (+ length padding) ctx)
+ (write-word header-address ctx))
+ (when *dump-verbose*
+ (format t "~&~D bytes written~%"
+ (- (file-length s) (ctx-stream-start ctx))))
+ (when print-statistics
+ (print-statistics ctx))))
+ pathname))
+
+(defun dump-all (object ctx)
+ (prog1
+ (sub-dump-object object ctx)
+ (loop while (cdr (ctx-worklist ctx)) do
+ (pop (ctx-worklist ctx))
+ (funcall (car (ctx-worklist ctx))))))
+
+(defconstant +fixup-length+ (* (+ 2 (length (make-fixup nil nil))) +n+))
+
+(defun update-weak-pointers (ctx)
+ (dolist (wp (ctx-weak-pointers ctx))
+ (multiple-value-bind (value alive)
+ (sb-ext:weak-pointer-value wp)
+ (let* ((value-address
+ (when alive
+ (gethash value (ctx-addresses ctx))))
+ (wp-pos (- (logandc2 (gethash wp (ctx-addresses ctx))
+ sb-vm:lowtag-mask)
+ (ctx-base-address ctx))))
+ (seek ctx (+ wp-pos +n+))
+ (cond
+ (value-address
+ ;; value has been dumped, write its address
+ (write-word value-address ctx))
+ (t
+ ;; break it
+ (write-word (sb-kernel:get-lisp-obj-address nil) ctx)
+ (write-word (sb-kernel:get-lisp-obj-address t) ctx)))))))
+
+(defun dump-fixups (ctx)
+ (setf (ctx-fixups ctx) (sort (ctx-fixups ctx) #'< :key #'fixup-type))
+ (let ((fixups (reverse (ctx-fixups ctx)))
+ (fixup-start (align (ctx-position ctx))))
+ (setf (ctx-position ctx) fixup-start)
+ (dolist (f fixups)
+ (setf (gethash f (ctx-addresses ctx))
+ (logior (+ (ctx-base-address ctx) (ctx-position ctx))
+ sb-vm:other-pointer-lowtag))
+ (incf (ctx-position ctx) +fixup-length+))
+ (loop
+ for f in fixups
+ for pos from fixup-start by +fixup-length+
+ do
+ (when *dump-print* (trace-fixup f pos))
+ (setf (fixup-locations f)
+ (coerce
+ (fixup-locations f)
+ `(simple-array (unsigned-byte ,sb-vm:n-word-bits) (*))))
+ (funcall (dump-simple-vector f ctx pos t)))))
+
+(defun simplify-type (type)
+ (cond
+ ((and (listp type)
+ (eq (car type) 'simple-array)
+ (subtypep (second type) 'integer))
+ '(simple-array "subtype of integer"))
+ ((and (subtypep type 'simple-array) (listp type))
+ (list (car type) "something or other"))
+ (t
+ type)))
+
+(defun print-statistics (ctx)
+ (let* ((n (length *fixup-names*))
+ (fixup-types (make-array n :initial-element 0))
+ (fixup-locations (make-array n :initial-element 0)))
+ (format t "~&fixups by type:~%")
+ (dolist (f (ctx-fixups ctx))
+ (incf (elt fixup-types (fixup-type f)))
+ (incf (elt fixup-locations (fixup-type f)) (length (fixup-locations f))))
+ (loop
+ for type across *fixup-names*
+ for n across fixup-types
+ for locations across fixup-locations
+ do
+ (when (plusp n)
+ (format t "~10D ~A (~D locations)~%" n type locations))))
+ (let ((types (make-hash-table :test 'equal)))
+ (maphash (lambda (object address)
+ (when (integerp address)
+ (incf (gethash (simplify-type (type-of object)) types 0))))
+ (ctx-addresses ctx))
+ (format t "~&number of objects by type:~%")
+ (let ((stats '()))
+ (maphash (lambda (type n) (push (cons type n) stats)) types)
+ (loop for (type . n) in (sort stats #'> :key #'cdr) do
+ (format t "~10D ~S~%" n type)))))
+
+(defun write-word (object ctx)
+ (unless (integerp object)
+ (push (tell ctx) (fixup-locations object))
+ (setf object +invalid+))
+ (%write-word object (ctx-stream ctx)))
+
+(defun %write-word (object s)
+ (declare (optimize (sb-ext:inhibit-warnings 3)))
+ (if #.(eq sb-c::*backend-byte-order* :big-endian)
+ (loop
+ for i from (- sb-vm:n-word-bits 8) downto 0 by 8
+ do (write-byte (ldb (byte 8 i) object) s))
+ (loop
+ for i from 0 below sb-vm:n-word-bits by 8
+ do (write-byte (ldb (byte 8 i) object) s))))
+
+(defun seek (ctx pos)
+ (file-position (ctx-stream ctx) (+ (ctx-stream-start ctx) pos)))
+
+(defun tell (ctx)
+ (- (file-position (ctx-stream ctx)) (ctx-stream-start ctx)))
+
+(defun native-address (object)
+ (logandc2 (sb-kernel:get-lisp-obj-address object) sb-vm:lowtag-mask))
+
+(defun native-pointer (object)
+ (sb-sys:int-sap (native-address object)))
+
+(defun make-header-word (data widetag)
+ (logior (ash data sb-vm:n-widetag-bits) widetag))
+
+(defun object-ref-word (object index)
+ (sb-sys:without-gcing
+ (sb-sys:sap-ref-word (native-pointer object) (* index +n+))))
+
+(defun (setf object-ref-word) (newval object index)
+ (sb-sys:without-gcing
+ (setf (sb-sys:sap-ref-word (native-pointer object) (* index +n+))
+ newval)))
+
+(defun object-ref-lispobj (object index)
+ (sb-sys:without-gcing
+ (sb-kernel:make-lisp-obj
+ (sb-sys:sap-ref-word (native-pointer object) (* index +n+)))))
+
+(defun align (address)
+ (- address (nth-value 1 (ceiling address (1+ sb-vm:lowtag-mask)))))
+
+(defun make-address (raw-pointer lowtag)
+ (logior raw-pointer lowtag))
+
+(defun forcep (object ctx)
+ (or (gethash object (ctx-force ctx))
+ (etypecase object
+ (package nil)
+ (symbol
+ (or (null (symbol-package object))
+ (forcep (symbol-package object) ctx)))
+ (sb-kernel:classoid (forcep (sb-kernel:classoid-name object) ctx))
+ (sb-kernel:layout (forcep (sb-kernel:layout-classoid object) ctx))
+ (sb-kernel:fdefn
+ (let ((name (sb-kernel:fdefn-name object)))
+ (or (not (fixupable-function-p
+ (sb-kernel:fdefn-fun object)
+ name
+ ctx))
+ ;; fixme: isn't this vaguely like !fixupable-function-p (but
+ ;; worse, not exactly the same)? Should it be?
+ (typecase name
+ (symbol (and (symbolp name) (forcep name ctx)))
+ (list
+ (or (some (lambda (x) (and (symbolp x) (forcep x ctx)))
+ name)
+ ;; always dump ctor fdefns
+ (eq 'sb-pcl::ctor (car name))
+ ;; ditto for accessors
+ (eq 'sb-pcl::slot-accessor (car name))))
+ (t nil)))))
+ (sb-kernel:named-type
+ (let ((name (sb-kernel:named-type-name object)))
+ (and (symbolp name) (forcep name ctx))))
+ (sb-kernel:array-type
+ nil)
+ (class
+ (or (not (slot-boundp object 'sb-pcl::name)) ;argh. FIXME!
+ (forcep (class-name object) ctx)))
+ (function nil))))
+
+(defun slot-accessor-p (gf)
+ (let ((x (sb-mop:generic-function-name gf)))
+ (and (listp x) (eq (car x) 'sb-pcl::slot-accessor))))
+
+(defun dump-fixup (object ctx)
+ (let ((fixup
+ (etypecase object
+ (package
+ (make-fixup +package-fixup+ (package-name object)))
+ (symbol
+ (make-symbol-fixup
+ +symbol-fixup+
+ (symbol-package object)
+ (symbol-name object)))
+ (sb-kernel:classoid
+ (make-fixup +classoid-fixup+ (sb-kernel:classoid-name object)))
+ (sb-kernel:layout
+ (make-fixup +layout-fixup+ (sb-kernel:layout-classoid object)))
+ (sb-kernel:fdefn
+ (make-fixup +fdefn-fixup+ (sb-kernel:fdefn-name object)))
+ (sb-kernel:named-type
+ (make-fixup +named-type-fixup+
+ (sb-kernel:named-type-name object)))
+ (sb-kernel:array-type
+ (make-fixup +array-type-fixup+
+ (list :dimensions
+ (sb-kernel::array-type-dimensions object)
+ :complexp
+ (sb-kernel::array-type-complexp object)
+ :element-type
+ (sb-kernel::array-type-element-type object)
+ :specialized-element-type
+ (sb-kernel::array-type-specialized-element-type
+ object))))
+ (class (make-fixup +class-fixup+ (class-name object)))
+ (generic-function
+ (if (slot-accessor-p object)
+ (make-fixup +slot-accessor-fixup+
+ (sb-mop:generic-function-name object))
+ (make-fixup +function-fixup+
+ (sb-mop:generic-function-name object))))
+ (sb-pcl::ctor
+ (make-fixup +ctor-fixup+
+ (list* (sb-pcl::ctor-function-name object)
+ (sb-pcl::ctor-class-name object)
+ (sb-pcl::ctor-initargs object))))
+ (function
+ ;; murmeltypsicheresprachemurmel
+ (assert (eql (sb-kernel:widetag-of object)
+ sb-vm:simple-fun-header-widetag))
+ (make-fixup +function-fixup+
+ (sb-kernel:%simple-fun-name object))))))
+ (setf (gethash object (ctx-addresses ctx)) fixup)
+ (%build-fixup fixup ctx)))
+
+(defun %build-fixup (fixup ctx)
+ (let ((*disable-customizer* t))
+ (sub-dump-object (fixup-id fixup) ctx)
+ (sub-dump-object (fixup-id2 fixup) ctx))
+ (push fixup (ctx-fixups ctx))
+ fixup)
+
+(defun trace-fixup (object pos)
+ (format *trace-output* "~&~8,'0X [~A] ~A ~A~{ #x~X~}~%"
+ pos
+ (elt *fixup-names* (fixup-type object))
+ (fixup-id object)
+ (fixup-id2 object)
+ (fixup-locations object)))
+
+(defun trace-object (object ctx)
+ (format *trace-output* "~&~8,'0X " (ctx-position ctx))
+ (if (and *disable-customizer*
+ (typep object 'simple-vector)
+ (not (stringp object))
+ (/= (length object)
+ (load-time-value (length (make-fixup -1 nil)))))
+ (format *trace-output* "[FILE HEADER] ")
+ (handler-case
+ (write object
+ :stream *trace-output*
+ :pretty nil
+ :escape t
+ :circle t
+ :level 3
+ :length 4)
+ (serious-condition (c)
+ (ignore-errors (format *trace-output* "printer error: ~A" c)))))
+ (fresh-line *trace-output*))
+
+(defun function-name-identifier (name)
+ (cond
+ ((symbolp name)
+ name)
+ ((and (listp name)
+ (eq (car name) 'setf)
+ (symbolp (second name)))
+ (second name))))
+
+(defun fixupable-function-p (fn name ctx)
+ (let ((id (function-name-identifier name)))
+ (and (not (forcep fn ctx)) ;fixme: check other entry-points, too?
+ id
+ (not (forcep id ctx))
+ (not (and (listp name) (eq (car name) 'sb-pcl::fast-method)))
+ (let ((fdefn (sb-int:info :function :definition name)))
+ (and fdefn (eq fn (sb-kernel:fdefn-fun fdefn)))))))
+
+(defun sub-dump-object (object ctx &key fixup-only)
+ (cond
+ ;; already seen
+ ((gethash object (ctx-addresses ctx)))
+ ;; immediate
+ ((or (null object)
+ (eq object t)
+ (evenp (sb-kernel:lowtag-of object)))
+ (sb-kernel:get-lisp-obj-address object))
+ ;; customizer/user-defined fixups
+ ((and (ctx-customizer ctx)
+ (not *disable-customizer*)
+ (multiple-value-bind (dumpp data1 data2)
+ (funcall (ctx-customizer ctx) object)
+ (ecase dumpp
+ ((t) nil)
+ ((nil)
+ (setf (gethash object (ctx-addresses ctx))
+ (sub-dump-object data1 ctx :fixup-only fixup-only)))
+ (:fixup
+ (let ((fixup (make-user-fixup +user-fixup+ data1 data2)))
+ (%build-fixup fixup ctx)
+ (setf (gethash object (ctx-addresses ctx)) fixup)))))))
+ ;; other fixup, unless overriden
+ ((and (typep object '(or package symbol class sb-kernel:layout
+ sb-kernel:classoid sb-kernel:fdefn
+ sb-kernel:named-type sb-kernel:array-type))
+ (not (forcep object ctx)))
+ (dump-fixup object ctx))
+ ;; functions
+ ((and (functionp object)
+ (eql (sb-kernel:widetag-of object) sb-vm:simple-fun-header-widetag))
+ ;; Funktionsobjekte muessten wir eigentlich dumpen, weil sie nicht
+ ;; in dem Sinne eindeutig sind. Wenn wir aber eine Funktion finden,
+ ;; die tatsaechlich so exakt wieder ueber ihren Namen auffindbar ist,
+ ;; dumpen wir mal opportunistisch doch ein Fixup um Platz zu sparen.
+ ;; In vielen Faellen sollte das so ohnehin richtiger sein.
+ (cond
+ ((fixupable-function-p object
+ (sb-kernel:%simple-fun-name object)
+ ctx)
+ (dump-fixup object ctx))
+ (t
+ (when fixup-only
+ (return-from sub-dump-object nil))
+ (sub-dump-object (simple-fun-code-object object) ctx)
+ (gethash object (ctx-addresses ctx)))))
+ ((and (typep object 'generic-function)
+ (slot-boundp object 'sb-pcl::name)
+ (or (slot-accessor-p object) ;never dump slot accessors
+ (fixupable-function-p object
+ (sb-mop:generic-function-name object)
+ ctx)))
+ (dump-fixup object ctx))
+ ((typep object 'sb-pcl::ctor)
+ ;; never dump ctors
+ (dump-fixup object ctx))
+ ((eq object sb-impl::*physical-host*)
+ (let ((fixup (make-fixup +variable-fixup+ 'sb-impl::*physical-host*)))
+ (setf (gethash object (ctx-addresses ctx)) fixup)
+ (%build-fixup fixup ctx)))
+ ;; ordinary dumpable objects
+ (t
+ (when fixup-only
+ (return-from sub-dump-object nil))
+ (setf (ctx-position ctx) (align (ctx-position ctx)))
+ (when *dump-print*
+ (trace-object object ctx))
+ (let* ((pos (ctx-position ctx))
+ (address
+ (make-address (+ (ctx-base-address ctx) pos)
+ (sb-kernel:lowtag-of object))))
+ (setf (gethash object (ctx-addresses ctx)) address)
+ (let ((fn (dump-nonfixup object ctx pos)))
+ (when fn
+ (push fn (cdr (ctx-worklist-tail ctx)))
+ (setf (ctx-worklist-tail ctx)
+ (cdr (ctx-worklist-tail ctx)))))
+ address))))
+
+(defun dump-nonfixup (object ctx pos)
+ (typecase object
+ (cons (dump-cons object ctx pos))
+ ((or integer single-float double-float (complex single-float)
+ (complex double-float) #+long-float (complex long-float)
+ sb-sys:system-area-pointer)
+ (dump-unboxed object ctx pos))
+ ((or symbol ratio complex)
+ (dump-boxed object ctx pos))
+ (simple-vector (dump-simple-vector object ctx pos))
+ ((simple-array * (*)) (dump-primitive-vector object ctx pos))
+ (array (dump-boxed object ctx pos))
+ (sb-kernel:instance (dump-instance object ctx pos))
+ (sb-kernel:code-component (dump-code-component object ctx pos))
+ (function (dump-non-simple-fun object ctx pos))
+ (sb-kernel:fdefn (dump-fdefn object ctx pos))
+ (sb-ext:weak-pointer
+ (multiple-value-bind (value alive)
+ (sb-ext:weak-pointer-value object)
+ (prog1
+ (dump-unboxed object ctx pos)
+ (when alive
+ (sub-dump-object value ctx
+ ;; don't dump the actual value here, but
+ ;; if it's fixupable, dump the fixup to avoid
+ ;; breaking the reference needlessly
+ :fixup-only t)
+ (push object (ctx-weak-pointers ctx))))))
+ (t
+ (if (sb-di::indirect-value-cell-p object)
+ (dump-boxed object ctx pos)
+ (error "cannot dump object ~S" object)))))
+
+(defun dump-cons (object ctx pos)
+ (incf (ctx-position ctx) +2n+)
+ (lambda ()
+ (let ((car (sub-dump-object (car object) ctx))
+ (cdr (sub-dump-object (cdr object) ctx)))
+ (seek ctx pos)
+ (write-word car ctx)
+ (write-word cdr ctx))))
+
+(defun dump-boxed (object ctx pos)
+ (let ((len (sb-kernel:get-header-data object)))
+ (incf (ctx-position ctx) (* (1+ len) +n+))
+ (lambda ()
+ (let ((slots
+ (loop
+ for i from 1 to len
+ collect (sub-dump-object (object-ref-lispobj object i) ctx))))
+ (seek ctx pos)
+ (write-word (make-header-word len (sb-kernel:widetag-of object)) ctx)
+ (dolist (slot slots)
+ (write-word slot ctx))))))
+
+(defun dump-unboxed (object ctx pos)
+ (let ((len (sb-kernel:get-header-data object)))
+ (incf (ctx-position ctx) (* (1+ len) +n+))
+ (seek ctx pos)
+ (dotimes (i (1+ len))
+ (write-word (object-ref-word object i) ctx))
+ nil))
+
+(defun dump-simple-vector (object ctx pos &optional fixup)
+ (let ((length (length object))
+ (header (sb-kernel:get-header-data object)))
+ (when (eql header sb-vm:vector-valid-hashing-subtype)
+ (let ((fn (sb-impl::hash-table-hash-fun (aref object 0))))
+ (when (loop
+ for k being each hash-key in (aref object 0)
+ thereis (nth-value 1 (funcall fn k)))
+ (setf header sb-vm:vector-must-rehash-subtype))))
+ (unless fixup
+ (incf (ctx-position ctx) (* (+ 2 length) +n+)))
+ (lambda ()
+ (let ((elements (map 'vector
+ (lambda (elt) (sub-dump-object elt ctx))
+ object)))
+ (seek ctx pos)
+ (write-word (make-header-word header (sb-kernel:widetag-of object))
+ ctx)
+ (write-word (sb-vm:fixnumize length) ctx)
+ (loop for elt across elements do
+ (write-word elt ctx))))))
+
+(defun size-of (object)
+ (sb-sys:with-pinned-objects (object)
+ (sb-alien:with-alien
+ ((fn (* (function sb-alien:long (* t)))
+ (sb-sys:sap-ref-sap (sb-alien:alien-sap sizetab)
+ (* +n+ (sb-kernel:widetag-of object)))))
+ (sb-alien:alien-funcall fn (native-pointer object)))))
+
+(defun dump-primitive-vector (object ctx pos)
+ (let ((full-length (align (* +n+ (size-of object)))))
+ (incf (ctx-position ctx) full-length)
+ (seek ctx pos)
+ (dotimes (i (truncate full-length +n+))
+ (write-word (object-ref-word object i) ctx))
+ nil))
+
+(defun dump-instance (instance ctx pos)
+ (let* ((len (sb-kernel:%instance-length instance))
+ (layout (sb-kernel:%instance-layout instance))
+ (nuntagged (sb-kernel:layout-n-untagged-slots layout)))
+ (incf (ctx-position ctx) (* (1+ len) +n+))
+ (lambda ()
+ (let* ((slots
+ (loop
+ for i from 0 below (- len nuntagged)
+ collect
+ (sub-dump-object (sb-kernel:%instance-ref instance i)
+ ctx)))
+ (l (pop slots)))
+ (seek ctx pos)
+ (write-word (make-header-word len sb-vm:instance-header-widetag) ctx)
+ (cond
+ ((integerp l)
+ (write-word l ctx))
+ (t
+ ;; if replaced with a fixup, store nuntagged here, so that
+ ;; relocation knows what to da
+ (push (tell ctx) (fixup-locations l))
+ (write-word (sb-vm:fixnumize nuntagged) ctx)))
+ (dolist (slot slots)
+ (write-word slot ctx))
+ (dotimes (i nuntagged)
+ (write-word
+ (sb-kernel:%raw-instance-ref/word instance (- nuntagged i 1))
+ ctx))))))
+
+(defun simple-fun-code-object (fun)
+ (sb-sys:with-pinned-objects (fun)
+ (let* ((fun-sap (native-pointer fun))
+ (header-value
+ (ash (sb-sys:sap-ref-word fun-sap 0) (- sb-vm:n-widetag-bits))))
+ (sb-kernel:make-lisp-obj
+ (logior (- (sb-sys:sap-int fun-sap) (* header-value +n+))
+ sb-vm:other-pointer-lowtag)))))
+
+;; fixme: can this be done by DUMP-PACKAGE?
+(defun note-fast-method-plist (fun ctx)
+ (let ((plist (sb-pcl::method-function-plist fun)))
+ (when plist
+ (%build-fixup (make-fast-method-fixup +fast-method-fixup+ fun plist)
+ ctx))))
+
+(defun dump-code-component (code ctx pos)
+ (let* ((new-address (+ (ctx-base-address ctx) pos))
+ (simple-funs
+ (loop
+ for fun = (sb-kernel:%code-entry-points code)
+ :then (sb-kernel:%simple-fun-next fun)
+ while fun
+ collect fun))
+ (n-header-words (sb-kernel:get-header-data code))
+ (n-code-words (sb-kernel:%code-code-size code))
+ (n-bytes (align (* +n+ (+ n-header-words n-code-words)))))
+ (incf (ctx-position ctx) n-bytes)
+ ;; we register the simple-funs here since they don't dump themselves
+ (sb-sys:with-pinned-objects (code)
+ (let* ((old-address (native-address code))
+ (displacement (- new-address old-address)))
+ (dolist (fun simple-funs)
+ (setf (gethash fun (ctx-addresses ctx))
+ (logior (+ (native-address fun) displacement)
+ sb-vm:fun-pointer-lowtag)))))
+ (lambda ()
+ (sb-sys:with-pinned-objects (code)
+ (let* ((old-address (native-address code))
+ (code-sap (sb-sys:int-sap old-address))
+ (displacement (- new-address old-address))
+ #+x86
+ (old-end-address (+ old-address n-bytes))
+ (data (make-array n-bytes :element-type '(unsigned-byte 8))))
+ ;; grab the whole thing so that fixups will be easier to do
+ (dotimes (i n-bytes)
+ (setf (elt data i) (sb-sys:sap-ref-8 code-sap i)))
+ (labels ((set-word (byte-offset value)
+ (declare (optimize (sb-ext:inhibit-warnings 3)))
+ (unless (integerp value)
+ (push (+ pos byte-offset) (fixup-locations value))
+ (setf value +invalid+))
+ (if #.(eq sb-c::*backend-byte-order* :big-endian)
+ (loop
+ for i from (- sb-vm:n-word-bits 8) downto 0 by 8
+ for j from byte-offset
+ do (setf (elt data j) (ldb (byte 8 i) value)))
+ (loop
+ for i from 0 below sb-vm:n-word-bits by 8
+ for j from byte-offset
+ do (setf (elt data j) (ldb (byte 8 i) value)))))
+ (dump (i)
+ (let ((address
+ (sub-dump-object (object-ref-lispobj code i) ctx)))
+ (set-word (* +n+ i) address))))
+ ;; update all descriptors
+ (loop
+ for i from 1 below n-header-words
+ do (dump i))
+ (dolist (fun simple-funs)
+ (let ((x (truncate (- (native-address fun) old-address) +n+)))
+ #+(or x86 x86-64)
+ ;; SB-VM:SIMPLE-FUN-SELF-SLOT != SB-KERNEL:%SIMPLE-FUN-SELF
+ (set-word (* (1+ x) +n+)
+ (+ (native-address fun)
+ displacement
+ (* sb-vm:simple-fun-code-offset
+ sb-vm:n-word-bytes)))
+ #-(or x86 x86-64)
+ (dump (1+ x))
+ (loop
+ for i from (+ x 2) below (+ x sb-vm:simple-fun-code-offset)
+ do (dump i))))
+ (dolist (ref (gethash code *foreign-fixups*))
+ (%build-fixup (make-foreign-fixup +foreign-fixup+ ref code)
+ ctx))
+ ;; apply fixups
+ #+x86
+ (let ((fixups
+ (sb-kernel:code-header-ref code sb-vm:code-constants-offset)))
+ (cond
+ ((typep fixups '(simple-array sb-vm:word (*)))
+ (loop for fixup across fixups do
+ (let* ((offset (+ fixup (* +n+ n-header-words)))
+ (old-value (sb-sys:sap-ref-word code-sap offset))
+ (new-value
+ (if (<= old-address
+ old-value
+ (1- old-end-address))
+ (+ old-value displacement)
+ (- old-value displacement))))
+ (set-word offset new-value))))
+ (t
+ ;; FIXME: happens quite often, so seems to be "normal" in at
+ ;; least some cases. Should better investigate this though.
+ #+(or)
+ (error "cowardly refusing to dump function without fixup vector")))))
+ ;; fixme: can this be done by DUMP-PACKAGE?
+ (dolist (fun simple-funs)
+ (let ((name (sb-kernel:%simple-fun-name fun)))
+ (when (and (listp name) (eq (car name) 'sb-pcl::fast-method))
+ (note-fast-method-plist fun ctx))))
+ (seek ctx pos)
+ (write-sequence data (ctx-stream ctx)))))))
+
+(defun dump-non-simple-fun (object ctx pos)
+ (let ((len (sb-kernel:get-closure-length object)))
+ (incf (ctx-position ctx) (* (1+ len) +n+))
+ (lambda ()
+ (note-fast-method-plist object ctx)
+ (let ((fun (sub-dump-object (sb-kernel:%closure-fun object) ctx))
+ (slots
+ (loop
+ for i from 2 to len
+ collect (sub-dump-object (object-ref-lispobj object i) ctx))))
+ #+(or x86 x86-64)
+ (cond
+ ((integerp fun)
+ (setf fun
+ (+ (logandc2 fun sb-vm:lowtag-mask)
+ (* sb-vm:simple-fun-code-offset sb-vm:n-word-bytes))))
+ (t
+ ;; oops! fun was replaced by a fixup. will have to set
+ ;; this slot once the fixup has been resolved.
+ (setf fun +invalid+)
+ (%build-fixup (make-fixup +raw-address-fixup+ object) ctx)))
+ (seek ctx pos)
+ (write-word (make-header-word len (sb-kernel:widetag-of object)) ctx)
+ (write-word fun ctx)
+ (dolist (slot slots)
+ (write-word slot ctx))))))
+
+(defun dump-fdefn (object ctx pos)
+ (let ((len (sb-kernel:get-header-data object)))
+ (incf (ctx-position ctx) (* (1+ len) +n+))
+ (lambda ()
+ (let* ((name (sub-dump-object (sb-kernel:fdefn-name object) ctx))
+ (fun (sub-dump-object (sb-kernel:fdefn-fun object) ctx))
+ (raw-addr #-sparc (object-ref-word object 3)
+ ;; fixme: is the sparc case right?
+ #+sparc fun))
+ #-sparc
+ (when
+ ;; update raw-addr only if it pointed to fun's raw-addr already,
+ ;; because non-simple funs have `closure_tramp' in this slot instead.
+ (eql raw-addr
+ (+ (native-address (sb-kernel:fdefn-fun object))
+ (* sb-vm:simple-fun-code-offset sb-vm:n-word-bytes)))
+ (cond
+ ((integerp fun)
+ (setf raw-addr
+ (+ (logandc2 fun sb-vm:lowtag-mask)
+ (* sb-vm:simple-fun-code-offset sb-vm:n-word-bytes))))
+ (t
+ ;; oops! fun was replaced by a fixup. will have to set
+ ;; this slot once the fixup has been resolved.
+ (setf raw-addr +invalid+)
+ (%build-fixup (make-fixup +raw-address-fixup+ object) ctx))))
+ (seek ctx pos)
+ (write-word (make-header-word len (sb-kernel:widetag-of object)) ctx)
+ (write-word name ctx)
+ (write-word fun ctx)
+ (write-word raw-addr ctx)))))
Added: trunk/sb-heapdump/generation.h
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/generation.h Sun May 21 14:31:55 2006
@@ -0,0 +1,55 @@
+/* -*- indent-tabs-mode: nil -*- */
+/* this isn't in gencgc-internal.h, so we need to copy&paste it */
+
+enum {
+ HIGHEST_NORMAL_GENERATION = 5,
+ PSEUDO_STATIC_GENERATION,
+ SCRATCH_GENERATION,
+ NUM_GENERATIONS
+};
+
+struct generation {
+
+ /* the first page that gc_alloc() checks on its next call */
+ page_index_t alloc_start_page;
+
+ /* the first page that gc_alloc_unboxed() checks on its next call */
+ page_index_t alloc_unboxed_start_page;
+
+ /* the first page that gc_alloc_large (boxed) considers on its next
+ * call. (Although it always allocates after the boxed_region.) */
+ page_index_t alloc_large_start_page;
+
+ /* the first page that gc_alloc_large (unboxed) considers on its
+ * next call. (Although it always allocates after the
+ * current_unboxed_region.) */
+ page_index_t alloc_large_unboxed_start_page;
+
+ /* the bytes allocated to this generation */
+ long bytes_allocated;
+
+ /* the number of bytes at which to trigger a GC */
+ long gc_trigger;
+
+ /* to calculate a new level for gc_trigger */
+ long bytes_consed_between_gc;
+
+ /* the number of GCs since the last raise */
+ int num_gc;
+
+ /* the average age after which a GC will raise objects to the
+ * next generation */
+ int trigger_age;
+
+ /* the cumulative sum of the bytes allocated to this generation. It is
+ * cleared after a GC on this generations, and update before new
+ * objects are added from a GC of a younger generation. Dividing by
+ * the bytes_allocated will give the average age of the memory in
+ * this generation since its last GC. */
+ long cum_sum_bytes_allocated;
+
+ /* a minimum average memory age before a GC will occur helps
+ * prevent a GC when a large number of new live objects have been
+ * added, in which case a GC could be a waste of time */
+ double min_av_mem_age;
+};
Added: trunk/sb-heapdump/load.lisp
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/load.lisp Sun May 21 14:31:55 2006
@@ -0,0 +1,230 @@
+;;; -*- indent-tabs-mode: nil -*-
+
+;;; Copyright (c) 2006 David Lichteblau
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation files
+;;; (the "Software"), to deal in the Software without restriction,
+;;; including without limitation the rights to use, copy, modify, merge,
+;;; publish, distribute, sublicense, and/or sell copies of the Software,
+;;; and to permit persons to whom the Software is furnished to do so,
+;;; subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;;; SOFTWARE.
+
+(in-package :sb-heapdump)
+
+(defvar *dumpload-verbose* t)
+
+(defmacro with-timing ((&optional) &body body)
+ `(invoke-with-timing (lambda () , at body)))
+
+(sb-alien:define-alien-routine "map_dumpfile" sb-alien:unsigned-long
+ (fd sb-alien:int)
+ (offset sb-alien:unsigned-long)
+ (verbose sb-alien:int))
+
+(defun load-dumpfile (pathname &key customizer suppress-initializer start end)
+ (with-open-file (s pathname :element-type :default :external-format :utf8)
+ (let ((file-length (or end (file-length s)))
+ (offset (or start 0)))
+ (loop
+ (when *dumpload-verbose*
+ (format t "~&; loading ~A[~X]" pathname offset)
+ (force-output))
+ (multiple-value-bind (header length)
+ (sub-load-dumpfile s customizer offset)
+ (incf offset length)
+ (if (< offset file-length)
+ (initialize header suppress-initializer)
+ (return (initialize header suppress-initializer))))))))
+
+(defun initialize (header suppress-initializer)
+ (multiple-value-prog1
+ (cond
+ ((and (header-initializer header)
+ (not suppress-initializer))
+ (write-string! " init")
+ (with-timing ()
+ (funcall (car (header-initializer header))
+ (header-object header))))
+ (t
+ (values (header-object header)
+ (car (header-initializer header)))))
+ (when *dumpload-verbose*
+ (format t " done~%"))))
+
+(defun sub-load-dumpfile (s customizer offset)
+ ;; kludge: holding *already-in-gc* means losing *gc-pending* if some
+ ;; other thread wants to do GC in the (unlikely?) event of a race with
+ ;; us. However, using sb-sys:without-gcing instead of acquiring
+ ;; sb-kernel::*already-in-gc* doesn't work, it deadlocks somehow.
+ (sb-thread:with-mutex (sb-kernel::*already-in-gc*)
+ (sb-sys:without-interrupts
+ (write-string! " mmap")
+ (sb-kernel::gc-stop-the-world)
+ (unwind-protect
+ (let* ((verbose (if *dumpload-verbose* 1 0))
+ (base-sap
+ (with-timing ()
+ (sb-sys:int-sap
+ (map-dumpfile (sb-sys:fd-stream-fd s) offset verbose))))
+ (length (sb-sys:sap-ref-word base-sap +n+))
+ (header
+ (sb-kernel:make-lisp-obj (sb-sys:sap-ref-word base-sap +2n+)))
+ (bla (cons header nil)))
+ (write-string! " fixup")
+ (with-timing ()
+ (sb-ext:with-unlocked-packages (:sb-pcl)
+ (handler-bind ((style-warning #'muffle-warning))
+ (apply-fixups base-sap
+ (header-fixups header)
+ (or customizer
+ (car (header-customizer header)))))))
+ (values header length bla))
+ (sb-kernel::gc-start-the-world)))))
+
+(defun write-string! (str)
+ (when *dumpload-verbose*
+ (write-string str)
+ (force-output)))
+
+(defun invoke-with-timing (fn)
+ (if *dumpload-verbose*
+ (let ((a (get-internal-real-time)))
+ (multiple-value-prog1
+ (funcall fn)
+ (let ((b (get-internal-real-time)))
+ (format t " ~Fs"
+ (float (/ (- b a) internal-time-units-per-second)
+ 1.0s0)))))
+ (funcall fn)))
+
+(locally
+ (declare (optimize speed (safety 0) (debug 0) (space 0)))
+ (defun apply-fixups (base-sap fixups customizer)
+ (dolist (f fixups)
+ (let ((value
+ (sb-kernel:get-lisp-obj-address (resolve-fixup f customizer)))
+ (locations (fixup-locations f)))
+ (declare (type (simple-array (unsigned-byte #.sb-vm:n-word-bits) (*))
+ locations))
+ (loop
+ for location of-type (unsigned-byte #.sb-vm:n-positive-fixnum-bits)
+ across locations
+ do (setf (sb-sys:sap-ref-word base-sap location) value))))))
+
+(defun resolve-fixup (f customizer)
+ (ecase (fixup-type f)
+ (#.+package-fixup+
+ (let ((name (fixup-id f)))
+ (or (find-package name)
+ (error "referenced package ~S not present" name))))
+ (#.+symbol-fixup+
+ (intern (fixup-id f) (fixup-id2 f)))
+ (#.+classoid-fixup+
+ (sb-kernel:find-classoid (fixup-id f)))
+ (#.+layout-fixup+
+ (sb-kernel:classoid-layout (fixup-id f)))
+ (#.+fdefn-fixup+
+ (let* ((name (fixup-id f)))
+ (or (sb-int:info :function :definition name)
+ (error "referenced function ~S not present" name))))
+ (#.+named-type-fixup+
+ (let ((result (sb-kernel:values-specifier-type (fixup-id f))))
+ (check-type result sb-kernel:named-type)
+ result))
+ (#.+array-type-fixup+
+ (apply #'sb-kernel:make-array-type (fixup-id f)))
+ (#.+class-fixup+
+ (find-class (fixup-id f)))
+ (#.+function-fixup+
+ (fdefinition (fixup-id f)))
+ (#.+ctor-fixup+
+ (destructuring-bind (fn class &rest initargs)
+ (fixup-id f)
+ (sb-pcl::ensure-ctor fn class initargs)
+ (fdefinition fn)))
+ (#.+slot-accessor-fixup+
+ (let ((x (fixup-id f)))
+ (sb-pcl::ensure-accessor (fourth x) x (third x))
+ (fdefinition x)))
+ (#.+fast-method-fixup+
+ (setf (sb-pcl::method-function-plist (fixup-id f))
+ (fixup-id2 f))
+ nil)
+ (#.+raw-address-fixup+
+ (let ((object (fixup-id f)))
+ (if (functionp object)
+ (let* ((new-fun
+ (sb-kernel:get-lisp-obj-address
+ (sb-kernel:%closure-fun object))))
+ (setf (object-ref-word object 1)
+ (+ (logandc2 new-fun sb-vm:lowtag-mask)
+ (* sb-vm:simple-fun-code-offset
+ sb-vm:n-word-bytes))))
+ (let* ((new-fun
+ (sb-kernel:get-lisp-obj-address
+ (sb-kernel:fdefn-fun object))))
+ (setf (object-ref-word object 3)
+ (+ (logandc2 new-fun sb-vm:lowtag-mask)
+ (* sb-vm:simple-fun-code-offset
+ sb-vm:n-word-bytes)))))))
+ (#.+variable-fixup+
+ (symbol-value (fixup-id f)))
+ (#.+foreign-fixup+
+ (let* ((ref (fixup-id f))
+ (code (fixup-id2 f))
+ (address
+ (sb-sys:foreign-symbol-address
+ (foreign-ref-symbol ref)
+ (foreign-ref-datap ref))))
+ (push ref (gethash code *foreign-fixups*))
+ #+(or x86 x86-64)
+ (let* ((sap (native-pointer code))
+ (n-header-words (sb-kernel:get-header-data code))
+ (pos (+ (foreign-ref-offset ref) (* +n+ n-header-words))))
+ ;; -32, because these are :absolute fixups, not :absolute64
+ (setf (sb-sys:sap-ref-32 sap pos) address))
+ #+ppc
+ (sb-vm::fixup-code-object code
+ (foreign-ref-offset ref)
+ address
+ (foreign-ref-kind ref))))
+ (#.+user-fixup+
+ (funcall customizer (fixup-id f) (fixup-id2 f)))))
+
+(sb-alien:define-alien-routine ("relocate_dumpfile" relocate_dumpfile)
+ sb-alien:unsigned-long
+ (fd sb-alien:int)
+ (offset sb-alien:long)
+ (base sb-alien:unsigned-long))
+
+(defun relocate-dumpfiles
+ (pathnames &optional (base-address *default-base-address*))
+ (dolist (pathname pathnames)
+ (incf base-address (relocate-dumpfile pathname base-address))))
+
+(defun relocate-dumpfile
+ (pathname &optional (base-address *default-base-address*))
+ (with-open-file (s pathname :direction :io :if-exists :overwrite)
+ (let ((fd (sb-sys:fd-stream-fd s))
+ (file-length (file-length s))
+ (offset 0))
+ (loop while (< offset file-length) do
+ (format t "~&relocating ~A[~X] to ~8,'0X~%"
+ pathname offset base-address)
+ (let ((length (relocate_dumpfile fd offset base-address)))
+ (incf base-address length)
+ (incf offset length)))
+ file-length)))
Added: trunk/sb-heapdump/module.lisp
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/module.lisp Sun May 21 14:31:55 2006
@@ -0,0 +1,96 @@
+;;; -*- indent-tabs-mode: nil -*-
+
+;;; Copyright (c) 2006 David Lichteblau
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation files
+;;; (the "Software"), to deal in the Software without restriction,
+;;; including without limitation the rights to use, copy, modify, merge,
+;;; publish, distribute, sublicense, and/or sell copies of the Software,
+;;; and to permit persons to whom the Software is furnished to do so,
+;;; subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;;; SOFTWARE.
+
+(in-package :sb-heapdump)
+
+(defvar *central-registry*
+ (list *default-pathname-defaults*
+ (truename (sb-ext:posix-getenv "SBCL_HOME"))))
+
+(defun dump-systems (pathname systems package-names &key (if-exists :error))
+ (let* ((names (mapcar #'asdf::coerce-name systems))
+ (specs
+ (mapcar (lambda (name)
+ (or (gethash name asdf::*defined-systems*)
+ (error "system not found: ~A" name)))
+ names))
+ (depends-on
+ (loop
+ for (nil . system) in specs
+ for do-first = (slot-value system 'asdf::do-first)
+ for in-order-to-compile = (cdr (assoc 'asdf:compile-op do-first))
+ append (cdr (assoc 'asdf:load-op in-order-to-compile)))))
+ (setf depends-on (mapcar #'asdf::coerce-name depends-on))
+ (setf depends-on (remove-duplicates depends-on :test #'string=))
+ (setf depends-on (set-difference depends-on names :test #'string=))
+ (dump-packages
+ package-names
+ pathname
+ :initializer (lambda (packages)
+ (dolist (spec specs)
+ (let ((name (asdf:component-name (cdr spec))))
+ (setf (gethash name asdf::*defined-systems*) spec)))
+ (dolist (dep depends-on)
+ (unless (find (string-upcase dep) *modules* :test 'equal)
+ (when *dumpload-verbose*
+ (format t "~&; loading dependency ~A~%" dep))
+ (require dep)))
+ packages)
+ :if-exists if-exists)))
+
+(defmethod dump-system ((system symbol))
+ (dump-system (asdf:find-system system)))
+
+(defmethod dump-system ((system string))
+ (dump-system (asdf:find-system system)))
+
+(defmethod dump-system ((c asdf:component))
+ (error "Component ~A does not implement SB-HEAPDUMP:DUMP-SYSTEM." c))
+
+(defun coerce-name (name)
+ (etypecase name
+ (symbol (string-downcase (symbol-name name)))
+ (string name)))
+
+(defun find-heap-file (name)
+ (some (lambda (dir)
+ (let* ((defaults (eval dir))
+ (file (and defaults
+ (make-pathname
+ :defaults defaults :version :newest
+ :name name :type "heap" :case :local))))
+ (and file (probe-file file))))
+ *central-registry*))
+
+(defun module-provide-heapfile (name)
+ (setf name (coerce-name name))
+ (if (gethash name asdf::*defined-systems*)
+ nil
+ (let ((heap-file (find-heap-file name)))
+ (when heap-file
+ (load-dumpfile heap-file)
+ (provide (string-upcase name))
+ t))))
+
+(pushnew 'module-provide-heapfile sb-ext:*module-provider-functions*)
Added: trunk/sb-heapdump/pack.lisp
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/pack.lisp Sun May 21 14:31:55 2006
@@ -0,0 +1,221 @@
+;;; -*- indent-tabs-mode: nil -*-
+
+;;; Copyright (c) 2006 David Lichteblau
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation files
+;;; (the "Software"), to deal in the Software without restriction,
+;;; including without limitation the rights to use, copy, modify, merge,
+;;; publish, distribute, sublicense, and/or sell copies of the Software,
+;;; and to permit persons to whom the Software is furnished to do so,
+;;; subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;;; SOFTWARE.
+
+(in-package :sb-heapdump)
+
+(defstruct (package-data
+ (:type vector)
+ (:conc-name "PD-")
+ (:constructor make-package-data (packages)))
+ packages
+ (infos nil)
+ (find-class-cells nil)
+ (methods (make-hash-table))
+ (fast-methods nil))
+
+(defun dump-packages
+ (packages pathname
+ &rest keys
+ &key if-exists parameters print-statistics initializer force
+ customizer load-time-customizer base-address
+ force-specializers systems system-packages)
+ (declare (ignore parameters print-statistics customizer load-time-customizer
+ base-address))
+ (unless (listp packages)
+ (setf packages (list packages)))
+ (setf packages
+ (mapcar (lambda (p)
+ (or (find-package p) (error "package not found: ~A" p)))
+ packages))
+ (unless initializer
+ (setf initializer #'identity))
+ (when (or systems system-packages)
+ (dump-systems pathname systems system-packages :if-exists if-exists)
+ (setf if-exists :append))
+ (let ((pd (collect-package-data packages force)))
+ (dolist (x force-specializers)
+ (collect-method-data! pd x))
+ (apply #'dump-object
+ (or packages "dummy")
+ pathname
+ :force (append packages force)
+ :initializer (if packages
+ (lambda (new-packages)
+ (reinstall-package-data pd new-packages)
+ (funcall initializer new-packages))
+ initializer)
+ :if-exists if-exists
+ :allow-other-keys t
+ keys)))
+
+(defun reinstall-package-data (pd new-packages)
+ (dolist (package new-packages)
+ (sb-impl::enter-new-nicknames
+ package
+ (cons (package-name package) (package-nicknames package))))
+ (loop for (sym class . plist) in (pd-infos pd) do
+ (loop for (type def) on plist by #'cddr do
+ (setf (sb-int:info class type sym) def)))
+ (loop for (sym cell) on (pd-find-class-cells pd) by #'cddr do
+ (setf (gethash sym sb-pcl::*find-class*) cell))
+ (maphash (lambda (gf ms)
+ (dolist (m ms)
+ (setf (sb-mop:method-generic-function m) nil)
+ (sb-pcl::real-add-method gf m t))
+ (sb-pcl::update-dfun gf))
+ (pd-methods pd)))
+
+(defun collect-package-data (packages force)
+ (let ((pd (make-package-data packages)))
+ (dolist (package packages)
+ (do-symbols (sym package)
+ (when (eq (symbol-package sym) package)
+ (collect-symbol-data! pd sym))))
+ (dolist (x force)
+ (when (symbolp force)
+ (collect-symbol-data! pd x)))
+ pd))
+
+(defun collect-symbol-data! (pd sym)
+ (nconc-infos pd (infos sym))
+ (nconc-infos pd (infos `(setf ,sym) :function))
+ (let ((cell (gethash sym sb-pcl::*find-class*)))
+ (when cell
+ (push cell (pd-find-class-cells pd))
+ (push sym (pd-find-class-cells pd))
+ (let ((class (sb-pcl::find-class-cell-class cell)))
+ (when class
+ (collect-slot-data! pd class)
+ (collect-method-data! pd class))))))
+
+(defun nconc-infos (pd infos)
+ (setf (pd-infos pd) (nconc infos (pd-infos pd))))
+
+(defun collect-slot-data! (pd class)
+ (dolist (slot (sb-mop:class-slots class))
+ (dolist (rwb '(sb-pcl::reader
+ sb-pcl::writer
+ sb-pcl::boundp))
+ (nconc-infos pd (infos `(sb-pcl::slot-accessor
+ :global
+ ,(sb-mop:slot-definition-name slot)
+ ,rwb)
+ :function)))))
+
+(defun collect-method-data! (pd class)
+ (dolist (method (sb-mop:specializer-direct-methods class))
+ (let* ((gf (sb-mop:method-generic-function method))
+ (id (function-name-identifier
+ (sb-mop:generic-function-name gf))))
+ ;; fixme: ist das folgende auch noetig fuer:
+ ;; (slot-value method 'sb-pcl::function)
+ (let ((fm (sb-pcl::method-fast-function method)))
+ (when fm
+ (when
+ ;; FIXME!
+ (eq (car (sb-kernel:%fun-name fm)) 'sb-pcl::fast-method)
+ (push fm (pd-fast-methods pd))
+ (nconc-infos pd (infos (sb-kernel:%fun-name fm) :function)))))
+ (unless (and id (member (symbol-package id) (pd-packages pd)))
+ (push method (gethash gf (pd-methods pd)))))))
+
+(defun infos (name &optional class)
+ (let ((result '()))
+ (maphash (lambda (c class-info)
+ (when (or (null class) (eq c class))
+ (let ((types (sb-c::class-info-types class-info)))
+ (let ((plist
+ (loop
+ for type-info in types
+ for type = (sb-c::type-info-name type-info)
+ for (def hit)
+ := (multiple-value-list
+ (handler-case
+ (sb-int:info c type name)
+ ;; KLUDGE: there doesn't seem to be a
+ ;; way to suppress default values, and
+ ;; some of them throw errors.
+ (sb-int:bug ()
+ nil)))
+ when hit
+ append (list type def))))
+ (when plist
+ (push (list* name c plist) result))))))
+ sb-c::*info-classes*)
+ result))
+
+(defun make-executable
+ (heapfile
+ &key (output-pathname (make-pathname :type nil :defaults heapfile))
+ main-function
+ (if-exists :error))
+ (with-open-file (in heapfile :element-type '(unsigned-byte 8))
+ (with-open-file (trampoline
+ (make-pathname :name "trampoline"
+ :type nil
+ :defaults
+ (asdf:component-relative-pathname
+ (asdf:find-system :sb-heapdump)))
+ :element-type '(unsigned-byte 8))
+ (with-open-file
+ (out output-pathname
+ :direction :output
+ :element-type '(unsigned-byte 8)
+ ;; KLUDGE! See DUMP-OBJECT.
+ :if-exists (if (eq if-exists :append) :overwrite if-exists))
+ (when (eq if-exists :append)
+ (file-position out (file-length out)))
+ (copy-stream trampoline out)
+ (let* ((length (file-length out))
+ (padding
+ (- (nth-value 1 (ceiling length +page-size+)))))
+ (dotimes (x padding)
+ (write-byte 0 out))
+ (copy-stream in out)
+ (force-output out)
+ (when main-function
+ (dump-object (list :dummy)
+ out
+ :initializer (lambda (x)
+ (declare (ignore x))
+ (apply main-function
+ (cdr sb-ext:*posix-argv*)))
+ :if-exists :append))
+ (file-position out (file-length out))
+ (%write-word (+ length padding) out))))))
+
+;; copy-stream taken from SBCL source code
+;; contrib/sb-executable/sb-executable.lisp
+(defvar *stream-buffer-size* 8192)
+(defun copy-stream (from to)
+ "Copy into TO from FROM until end of the input stream, in blocks of
+*stream-buffer-size*. The streams should have the same element type."
+ (unless (subtypep (stream-element-type to) (stream-element-type from))
+ (error "Incompatible streams ~A and ~A." from to))
+ (let ((buf (make-array *stream-buffer-size*
+ :element-type (stream-element-type from))))
+ (loop
+ (let ((pos (read-sequence buf from)))
+ (when (zerop pos) (return))
+ (write-sequence buf to :end pos)))))
Added: trunk/sb-heapdump/package.lisp
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/package.lisp Sun May 21 14:31:55 2006
@@ -0,0 +1,29 @@
+;;; -*- indent-tabs-mode: nil -*-
+
+(in-package :cl-user)
+
+(defpackage :sb-heapdump
+ (:use :cl)
+ (:shadow #:defun #:lambda)
+ (:export #:*dumpload-verbose* #:*dump-verbose* #:*central-registry*
+ #:dump-object #:dump-packages #:dump-system
+ #:load-dumpfile
+ #:relocate-dumpfile #:relocate-dumpfiles
+ #:make-executable))
+
+(in-package :sb-heapdump)
+
+;; Give lambdas a name, since SBCL prints them only as ((LAMBDA ())) in
+;; backtraces otherwise, and that's not good enough with the large number
+;; of functions we have that use the lambda trick.
+(defmacro defun (name (&rest args) &body body)
+ (let ((declarationp (and (listp (car body)) (eq (caar body) 'declare))))
+ `(cl:defun ,name ,args
+ ,@(when declarationp
+ (list (car body)))
+ (macrolet ((lambda ((&rest args) &body body)
+ `(sb-int:named-lambda ,'(lambda ,name) ,args , at body)))
+ ,@(if declarationp (cdr body) body)))))
+
+(defmacro lambda ((&rest args) &body body)
+ `(cl:lambda ,args , at body))
Added: trunk/sb-heapdump/patch.lisp
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/patch.lisp Sun May 21 14:31:55 2006
@@ -0,0 +1,89 @@
+;;; -*- indent-tabs-mode: nil -*-
+
+;;; Copyright (c) 2006 David Lichteblau
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation files
+;;; (the "Software"), to deal in the Software without restriction,
+;;; including without limitation the rights to use, copy, modify, merge,
+;;; publish, distribute, sublicense, and/or sell copies of the Software,
+;;; and to permit persons to whom the Software is furnished to do so,
+;;; subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;;; SOFTWARE.
+
+(in-package :sb-heapdump)
+
+(defvar *foreign-fixups* (make-hash-table)) ;fixme: should be weak
+
+(defstruct (foreign-ref
+ (:constructor make-foreign-ref (offset kind symbol datap)))
+ offset
+ kind
+ symbol
+ datap)
+
+(sb-ext:with-unlocked-packages (:sb-fasl)
+ (macrolet
+ ((doit (datap)
+ `(let* ((kind (sb-fasl::pop-stack))
+ (code-object (sb-fasl::pop-stack))
+ (len (sb-fasl::read-byte-arg))
+ (sym (make-string len :element-type 'base-char)))
+ (sb-sys:read-n-bytes sb-fasl::*fasl-input-stream* sym 0 len)
+ (let* ((offset (sb-fasl::read-word-arg))
+ #-ppc
+ (oldval
+ (sb-sys:without-gcing
+ (sb-sys:sap-ref-32
+ (sb-kernel:code-instructions code-object)
+ offset))))
+ (sb-vm:fixup-code-object code-object
+ offset
+ (sb-sys:foreign-symbol-address sym)
+ kind)
+ (let ((fixups
+ (sb-kernel:code-header-ref
+ code-object
+ sb-vm:code-constants-offset)))
+ (unless (and (vectorp fixups) (find offset fixups))
+ #-ppc (assert (eq kind :absolute))
+ #-ppc (assert (zerop oldval))
+ (push (make-foreign-ref offset kind sym ,datap)
+ (gethash code-object *foreign-fixups*)))))
+ code-object)))
+ (sb-fasl::define-fop (sb-fasl::fop-foreign-fixup 147) (doit nil))
+ #+linkage-table
+ (sb-fasl::define-fop (sb-fasl::fop-foreign-dataref-fixup 150) (doit t))))
+
+(defvar *do-core-fixups* #'sb-c::do-core-fixups)
+
+(sb-ext:with-unlocked-packages (:sb-c)
+ (defun sb-c::do-core-fixups (code fixup-notes)
+ (dolist (note fixup-notes)
+ (let* ((kind (sb-c::fixup-note-kind note))
+ (fixup (sb-c::fixup-note-fixup note))
+ (offset (sb-c::fixup-note-position note))
+ (sym (sb-c::fixup-name fixup))
+ (flavor (sb-c::fixup-flavor fixup)))
+ (funcall *do-core-fixups* code (list note))
+ (when (or (eq flavor :foreign) (eq flavor :foreign-dataref))
+ (let ((fixups
+ (sb-kernel:code-header-ref
+ code
+ sb-vm:code-constants-offset))
+ (datap (eq flavor :foreign-dataref)))
+ (unless (and (vectorp fixups) (find offset fixups))
+ #-ppc (assert (eq kind :absolute))
+ (push (make-foreign-ref offset kind sym datap)
+ (gethash code *foreign-fixups*)))))))))
Added: trunk/sb-heapdump/relocate.c
==============================================================================
--- (empty file)
+++ trunk/sb-heapdump/relocate.c Sun May 21 14:31:55 2006
@@ -0,0 +1,633 @@
+/* -*- indent-tabs-mode: nil -*- */
+
+/* Copyright (c) 2006 David Lichteblau
+ * partly derived from SBCL source code (gc-common.c/gencgc.c)
+ *
+ * Tested on x86, x86-64, and PPC.
+ *
+ * When using this code to relocate memory not dumped by sb-heapdump,
+ * read the note in relocate_simple_vector.
+ */
+/*
+ * Permission is hereby granted, free of charge, to any person
+ * obtaining a copy of this software and associated documentation files
+ * (the "Software"), to deal in the Software without restriction,
+ * including without limitation the rights to use, copy, modify, merge,
+ * publish, distribute, sublicense, and/or sell copies of the Software,
+ * and to permit persons to whom the Software is furnished to do so,
+ * subject to the following conditions:
+ *
+ * The above copyright notice and this permission notice shall be
+ * included in all copies or substantial portions of the Software.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ * NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+ * BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+ * ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+ * CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+ * SOFTWARE.
+ */
+#include
+#include
+#include
+#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<
+#include
+#include
+#include
+#include
+#include
+#include
+#include
+
+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
From dlichteblau at common-lisp.net Sun May 28 14:27:44 2006
From: dlichteblau at common-lisp.net (dlichteblau at common-lisp.net)
Date: Sun, 28 May 2006 10:27:44 -0400 (EDT)
Subject: [steeldump-cvs] r5 - trunk/steeldump-web
Message-ID: <20060528142744.702192B02A@common-lisp.net>
Author: dlichteblau
Date: Sun May 28 10:27:42 2006
New Revision: 5
Added:
trunk/steeldump-web/building.html
Modified:
trunk/steeldump-web/index.html
Log:
moved development instruction to their own page
added version numbers
Added: trunk/steeldump-web/building.html
==============================================================================
--- (empty file)
+++ trunk/steeldump-web/building.html Sun May 28 10:27:42 2006
@@ -0,0 +1,261 @@
+
+
+
+
+ Steeldump
+
+
+
+
+ (You can skip this section if you just want to use steeldump
+ packages normally. See above for installation instructions.)
+
+
+ To help debugging or developing Steeldump, the following steps
+ should be enough to build your own steeldump packages:
+
+
+
+ Set up a chroot environment or virtual machine to compile
+ steeldump in.
+
+
+ If you really do not want to do this, keep this in mind:
+ Steeldump must be compiled in the exact same location
+ where it is going to be installed into,
+ /opt/steeldump. So you cannot run the steeldump
+ scripts in a filesystem where steeldump packages are already
+ installed.
+
+
+ Although it does not address safety issues, you can obviously
+ build a mock-up chroot very easily using mount -o bind,
+ so this should not be too much of an issue.
+
+
+ Create a new directory /opt/steeldump. In the build
+ environment, this directory should be owned by a non-root user.
+ (The build scripts will only run sudo briefly for each
+ package to fix file ownership before packaging the files up.
+ Building should be done normally under your non-root account.)
+
+
+ Check out the steeldump scripts from Subversion:
+
$ cd /opt/steeldump
+$ svn co svn://common-lisp.net/project/steeldump/svn/trunk/scripts
+
+
+ Run the first script:
+
/opt/steeldump$ ./scripts/init
+ -- or just look at what it does. It merely creates a few
+ directories and checks whether required software is installed.
+ CMUCL is used for building (you can use the debian-provided
+ cmucl package), and dpkg-dev tools as well as sudo are needed.
+
+
+ The first package you need to download and build is SBCL:
+
+ And that's it. After makedeb-all, you can find all packages in
+ the pool directory.
+
+
+ While debugging, however, you will probably want to build
+ individual packages instead of all in one go:
+
+
+
+ For every system, there is a separate fetch-foo
+ script. These fetch-scripts do not track dependencies
+ for you. When not using fetch-all, make sure to
+ download everything you need before trying to build.
+
+
+ The build-foo scripts can be invoked in an
+ arbitrary order. For example, building climacs will
+ automatically compile mcclim if it had not been compiled
+ yet. However, it does not actually create the dumpfile
+ for mcclim, you will still have to call build-mcclim
+ eventually before you can make its .deb file.
+
+
+ Finally, for makedeb-all note that it has one advantage
+ over the individual makedeb-foo scripts: Before
+ calling out to the others, makedeb-all relocates the
+ heap files to non-overlapping locations, speeding up loading of
+ the heap files a little.
+
+
+
+ If you got this far and have working packages in
+ /opt/steeldump/pool, send me a postcard.
+
+
+
+ Extending Steeldump
+
+
+
+ (You can skip this section if you just want to use steeldump
+ packages normally. See above for installation instructions.)
+
+
+ To add a new package called "blubba", create these files:
+
+
+
+ /opt/steeldump/scripts/fetch-blubba
+ This script must put the source code into
+ /opt/steeldump/src/blubba. Remove version numbers from
+ the directory name, if any.
+ Look at the other fetch scripts for ideas. Usually it is enough
+ to call one of the helper scripts, aux/fetch-url,
+ aux/fetch-cvs, or aux/fetch-svn. If you have
+ to patch the source code, this script is the right place to do
+ that.
+
+
+ /opt/steeldump/scripts/build-blubba
+ Usually this script is trivial and just
+ calls build-system. Copy
+ over /opt/steeldump/scripts/build-SAMPLE and change the
+ system name from "SAMPLESSYTEMNAME" to "blubba". This script
+ is the right place to call "make" if the system includes C code.
+
+
+ /opt/steeldump/scripts/lisp/build-blubba.lisp
+ This Lisp script is less trivial. Starting from the sample file
+ /opt/steeldump/scripts/lisp/build-SAMPLE.lisp, change
+ the system name from "SAMPLE" to "blubba", but review the
+ heap dumping logic carefully. The heap dumper needs to be told
+ about:
+
+
+ The packages that are to be dumped (look out for multiple
+ defpackage forms). This is the first argument
+ to dump-system.
+
+
+ The ASDF systems involved. If the .asd file contains
+ multiple system definitions, all of them must be listed
+ manually in the build script. (The :system
+ argument.)
+
+
+ The name of the package the .asd files defines and uses.
+ (The :system-package argument.)
+
+
+ You now have a first draft of the dumping script. Beware that
+ dumping is not the part where things tend to fail, it is the
+ loading and running of heap files where mistakes show up. The
+ heuristic used by the heapdumper is that it thinks in terms of
+ packages. For many systems, you will have to supply more
+ information than just the package names, because the software
+ often installs objects into variables contained
+ in other packages, slots of objects the heap dumper
+ cannot know about, etc.
+
+
+ Refer to sb-heapdump documentation on the precise logic used
+ by the dumper.
+
+
+ For CLIM systems in particular, application-defined command
+ tables and presentation types need to be extracted from
+ McCLIM-internal tables. CLIM also has methods that are
+ eql-specializing on objects like +flipping-ink+, so we must
+ guarantee uniqueness of these objects. For details, see
+ the build scripts for gsharp and climacs.
+
+
+ Any CLOS usage can be tricky. The heap dumper will (a)
+ include generic functions and all their methods in the
+ package the generic function's name is in (for example, the
+ MCCLIM package), and (b) additional methods in a different
+ package if those methods specialize on a class named by a
+ symbol in that other package (for example, methods defined
+ for classes in the CLIMACS package). One corollary of these
+ rules is that we must not dump the McCLIM package after
+ having loaded Climacs into the same core, because then
+ loading of McCLIM would fail trying to find the CLIMACS
+ package.
+
+
+
+
+ /opt/steeldump/scripts/descriptions/blubba
+ This file ends up as the Description: header in the
+ Debian package's control file.
+ Again there is a skeleton file:
+ /opt/steeldump/scripts/descriptions/SAMPLE.
+
+
+ /opt/steeldump/scripts/makedeb-blubba
+ This scripts collect all files to be installed and creates the
+ .deb archive. Starting
+ with /opt/steeldump/scripts/makedeb-SAMPLE,
+ replace SAMPLESYSTEMNAME with "blubba", and DEPENDENCIES with other
+ steeldump packages that "blubba" depends on. Omit the
+ "steeldump-" prefix and version number, the helper script
+ inserts those for you.
+
+
+
+
Modified: trunk/steeldump-web/index.html
==============================================================================
--- trunk/steeldump-web/index.html (original)
+++ trunk/steeldump-web/index.html Sun May 28 10:27:42 2006
@@ -18,8 +18,11 @@
@@ -204,222 +249,5 @@
If, however, the bug is also present is the upstream source code,
please send your report directly to the upstream project. Thanks.
-
-
- Building Steeldump
-
-
-
- (You can skip this section if you just want to use steeldump
- packages normally. See above for installation instructions.)
-
-
- To help debugging or developing Steeldump, the following steps
- should be enough to build your own steeldump packages:
-
-
-
- Set up a chroot environment or virtual machine to compile
- steeldump in.
-
-
- If you really do not want to do this, keep this in mind:
- Steeldump must be compiled in the exact same location
- where it is going to be installed into,
- /opt/steeldump. So you cannot run the steeldump
- scripts in a filesystem where steeldump packages are already
- installed.
-
-
- Although it does not address safety issues, you can obviously
- build a mock-up chroot very easily using mount -o bind,
- so this should not be too much of an issue.
-
-
- Create a new directory /opt/steeldump. In the build
- environment, this directory should be owned by a non-root user.
- (The build scripts will only run sudo briefly for each
- package to fix file ownership before packaging the files up.
- Building should be done normally under your non-root account.)
-
-
- Check out the steeldump scripts from Subversion:
-
$ cd /opt/steeldump
-$ svn co svn://common-lisp.net/project/steeldump/svn/trunk/scripts
-
-
- Run the first script:
-
/opt/steeldump$ ./scripts/init
- -- or just look at what it does. It merely creates a few
- directories and checks whether required software is installed.
- CMUCL is used for building (you can use the debian-provided
- cmucl package), and dpkg-dev tools as well as sudo are needed.
-
-
- The first package you need to download and build is SBCL:
-
- And that's it. After makedeb-all, you can find all packages in
- the pool directory.
-
-
- While debugging, however, you will probably want to build
- individual packages instead of all in one go:
-
-
-
- For every system, there is a separate fetch-foo
- script. These fetch-scripts do not track dependencies
- for you. When not using fetch-all, make sure to
- download everything you need before trying to build.
-
-
- The build-foo scripts can be invoked in an
- arbitrary order. For example, building climacs will
- automatically compile mcclim if it had not been compiled
- yet. However, it does not actually create the dumpfile
- for mcclim, you will still have to call build-mcclim
- eventually before you can make its .deb file.
-
-
- Finally, for makedeb-all note that it has one advantage
- over the individual makedeb-foo scripts: Before
- calling out to the others, makedeb-all relocates the
- heap files to non-overlapping locations, speeding up loading of
- the heap files a little.
-
-
-
- If you got this far and have working packages in
- /opt/steeldump/pool, send me a postcard.
-
-
-
- Extending Steeldump
-
-
-
- (You can skip this section if you just want to use steeldump
- packages normally. See above for installation instructions.)
-
-
- To add a new package called "blubba", create these files:
-
-
-
- /opt/steeldump/scripts/fetch-blubba
- This script must put the source code into
- /opt/steeldump/src/blubba. Remove version numbers from
- the directory name, if any.
- Look at the other fetch scripts for ideas. Usually it is enough
- to call one of the helper scripts, aux/fetch-url,
- aux/fetch-cvs, or aux/fetch-svn. If you have
- to patch the source code, this script is the right place to do
- that.
-
-
- /opt/steeldump/scripts/build-blubba
- Usually this script is trivial and just
- calls build-system. Copy
- over /opt/steeldump/scripts/build-SAMPLE and change the
- system name from "SAMPLESSYTEMNAME" to "blubba". This script
- is the right place to call "make" if the system includes C code.
-
-
- /opt/steeldump/scripts/lisp/build-blubba.lisp
- This Lisp script is less trivial. Starting from the sample file
- /opt/steeldump/scripts/lisp/build-SAMPLE.lisp, change
- the system name from "SAMPLE" to "blubba", but review the
- heap dumping logic carefully. The heap dumper needs to be told
- about:
-
-
- The packages that are to be dumped (look out for multiple
- defpackage forms). This is the first argument
- to dump-system.
-
-
- The ASDF systems involved. If the .asd file contains
- multiple system definitions, all of them must be listed
- manually in the build script. (The :system
- argument.)
-
-
- The name of the package the .asd files defines and uses.
- (The :system-package argument.)
-
-
- You now have a first draft of the dumping script. Beware that
- dumping is not the part where things tend to fail, it is the
- loading and running of heap files where mistakes show up. The
- heuristic used by the heapdumper is that it thinks in terms of
- packages. For many systems, you will have to supply more
- information than just the package names, because the software
- often installs objects into variables contained
- in other packages, slots of objects the heap dumper
- cannot know about, etc.
-
-
- Refer to sb-heapdump documentation on the precise logic used
- by the dumper.
-
-
- For CLIM systems in particular, application-defined command
- tables and presentation types need to be extracted from
- McCLIM-internal tables. CLIM also has methods that are
- eql-specializing on objects like +flipping-ink+, so we must
- guarantee uniqueness of these objects. For details, see
- the build scripts for gsharp and climacs.
-
-
- Any CLOS usage can be tricky. The heap dumper will (a)
- include generic functions and all their methods in the
- package the generic function's name is in (for example, the
- MCCLIM package), and (b) additional methods in a different
- package if those methods specialize on a class named by a
- symbol in that other package (for example, methods defined
- for classes in the CLIMACS package). One corollary of these
- rules is that we must not dump the McCLIM package after
- having loaded Climacs into the same core, because then
- loading of McCLIM would fail trying to find the CLIMACS
- package.
-
-
-
-
- /opt/steeldump/scripts/descriptions/blubba
- This file ends up as the Description: header in the
- Debian package's control file.
- Again there is a skeleton file:
- /opt/steeldump/scripts/descriptions/SAMPLE.
-
-
- /opt/steeldump/scripts/makedeb-blubba
- This scripts collect all files to be installed and creates the
- .deb archive. Starting
- with /opt/steeldump/scripts/makedeb-SAMPLE,
- replace SAMPLESYSTEMNAME with "blubba", and DEPENDENCIES with other
- steeldump packages that "blubba" depends on. Omit the
- "steeldump-" prefix and version number, the helper script
- inserts those for you.
-