May 2006 - steeldump-cvs@common-lisp.net - mailman3.common-lisp.net

[steeldump-cvs] r11 - trunk/scripts
by dlichteblau＠common-lisp.net 28 May '06

28 May '06

Author: dlichteblau Date: Sun May 28 14:38:27 2006 New Revision: 11 Modified: trunk/scripts/build-all trunk/scripts/fetch-all trunk/scripts/makedeb-all Log: noch stumpwm Modified: trunk/scripts/build-all ============================================================================== --- trunk/scripts/build-all (original) +++ trunk/scripts/build-all Sun May 28 14:38:27 2006 @@ -8,7 +8,7 @@ for system in climacs gsharp clx esa flexichain mcclim spatial-trees \ split-sequence cl-ppcre cl-fad tab-layout trivial-gray-streams \ - flexi-streams trivial-sockets cl-irc beirc eclipse + flexi-streams trivial-sockets cl-irc beirc eclipse stumpwm do f=/opt/steeldump/lib/sbcl/${system}.heap if test -e $f; then Modified: trunk/scripts/fetch-all ============================================================================== --- trunk/scripts/fetch-all (original) +++ trunk/scripts/fetch-all Sun May 28 14:38:27 2006 @@ -1,7 +1,7 @@ #!/bin/sh -e for system in sbcl clx esa flexichain mcclim spatial-trees split-sequence \ climacs gsharp cl-ppcre cl-fad tab-layout trivial-gray-streams \ - flexi-streams trivial-sockets cl-irc beirc eclipse + flexi-streams trivial-sockets cl-irc beirc eclipse stumpwm do if test -e /opt/steeldump/src/$system; then echo "$system already present, skipping" Modified: trunk/scripts/makedeb-all ============================================================================== --- trunk/scripts/makedeb-all (original) +++ trunk/scripts/makedeb-all Sun May 28 14:38:27 2006 @@ -23,3 +23,4 @@ /opt/steeldump/scripts/makedeb-cl-irc /opt/steeldump/scripts/makedeb-beirc /opt/steeldump/scripts/makedeb-eclipse +/opt/steeldump/scripts/makedeb-stumpwm

1 0

[steeldump-cvs] r10 - trunk/steeldump-web
by dlichteblau＠common-lisp.net 28 May '06

28 May '06

Author: dlichteblau Date: Sun May 28 14:38:15 2006 New Revision: 10 Modified: trunk/steeldump-web/index.html Log: new release Modified: trunk/steeldump-web/index.html ============================================================================== --- trunk/steeldump-web/index.html (original) +++ trunk/steeldump-web/index.html Sun May 28 14:38:15 2006 @@ -52,6 +52,14 @@ </tr> <tr> <td> + <li><a href="http://common-lisp.net/project/eclipse">eclipse</a></li> + </td> + <td align="right"> + <sub>CVS</sub> + </td> + </tr> + <tr> + <td> <li><a href="http://common-lisp.net/project/climacs">climacs</a></li> </td> <td align="right"> @@ -66,6 +74,14 @@ <sub>CVS</sub> </td> </tr> + <tr> + <td> + <li><a href="http://www.nongnu.org/stumpwm/">stumpwm</a></li> + </td> + <td align="right"> + <sub>CVS</sub> + </td> + </tr> </table> </div> <div class="sidebar-title"> @@ -214,6 +230,22 @@ </p> <h3>News</h3> + <b>2006-05-28</b> + <p> + New release based on SBCL 0.9.13. + </p> + <p> + Added two window managers written entirely in Lisp: + </p> + <ul> + <li>Eclipse, complete with themes and Gnome support.</li> + <li>And stumpwm, the minimalistic ratpoison-lookalike.</li> + </ul> + <p> + Minor addition: The CLIM Listener has its own startup script now, + included in the <tt>steeldump-mcclim</tt> package. + </p> + <b>2006-05-21</b> <p> First public release. Please test gently. Based on SBCL 0.9.12. @@ -248,7 +280,7 @@ Packages are all named <tt>steeldump-</tt><i>foo</i>. E.g., to install climacs, type <tt>aptitude install steeldump-climacs</tt>. All packages install exclusively to - <tt>/opt/steeldump</tt> and do not interact with the "normal" + <tt>/opt/steeldump</tt> and do not interact with the Lisp packages included in Debian at all. </p> <p>

1 0

[steeldump-cvs] r9 - in trunk/scripts: . data descriptions lisp patches
by dlichteblau＠common-lisp.net 28 May '06

28 May '06

Author: dlichteblau Date: Sun May 28 14:26:45 2006 New Revision: 9 Added: trunk/scripts/build-stumpwm (contents, props changed) trunk/scripts/data/stumpwm (contents, props changed) trunk/scripts/descriptions/stumpwm trunk/scripts/fetch-stumpwm (contents, props changed) trunk/scripts/lisp/build-stumpwm.lisp trunk/scripts/makedeb-stumpwm (contents, props changed) trunk/scripts/patches/stumpwm.diff Log: stumpwm Added: trunk/scripts/build-stumpwm ============================================================================== --- (empty file) +++ trunk/scripts/build-stumpwm Sun May 28 14:26:45 2006 @@ -0,0 +1,3 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/build-system stumpwm Added: trunk/scripts/data/stumpwm ============================================================================== --- (empty file) +++ trunk/scripts/data/stumpwm Sun May 28 14:26:45 2006 @@ -0,0 +1,9 @@ +#!/bin/sh +unset SBCL_HOME +exec /opt/steeldump/bin/sbcl \ + --noinform \ + --userinit /dev/null \ + --disable-debugger \ + --eval '(setf sb-heapdump:*dumpload-verbose* nil)' \ + --eval '(require :stumpwm)' \ + --eval '(progn (stumpwm:stumpwm) (sb-ext:quit))' Added: trunk/scripts/descriptions/stumpwm ============================================================================== --- (empty file) +++ trunk/scripts/descriptions/stumpwm Sun May 28 14:26:45 2006 @@ -0,0 +1,14 @@ +Description: A tiling, keyboard driven WM written in Common Lisp. (steeldump package) + Stumpwm is a tiling, keyboard driven X11 Window Manager written + entirely in Common Lisp. + . + If you're tired of flipping through themes like channel-surfing, and + going from one perfect-except-for-just-one-thing window manager to + another even-more-broken-in-some-other-way then perhaps Stumpwm can + help. + . + Stumpwm attempts to be customizable yet visually minimal. There are no + window decorations, no icons, and no buttons. It does have various + hooks to attach your personal customizations, and variables to tweak. + . + This is a non-Debian binary package from the steeldump repository. Added: trunk/scripts/fetch-stumpwm ============================================================================== --- (empty file) +++ trunk/scripts/fetch-stumpwm Sun May 28 14:26:45 2006 @@ -0,0 +1,7 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/fetch-cvs \ + :pserver:anoncvs@cvs.savannah.nongnu.org:/cvsroot/stumpwm \ + stumpwm +cd /opt/steeldump/src/stumpwm +patch -p0 </opt/steeldump/scripts/patches/stumpwm.diff Added: trunk/scripts/lisp/build-stumpwm.lisp ============================================================================== --- (empty file) +++ trunk/scripts/lisp/build-stumpwm.lisp Sun May 28 14:26:45 2006 @@ -0,0 +1,17 @@ +(sb-ext:disable-debugger) +(setf asdf:*central-registry* (list (car asdf:*central-registry*))) +(asdf:operate 'asdf:load-op :stumpwm) + +(defmethod sb-heapdump:dump-system + ((c (eql (asdf:find-system :stumpwm)))) + (sb-heapdump:dump-packages + '(:stumpwm) + "stumpwm.heap" + :if-exists :rename-and-delete + :systems '(:stumpwm) + :system-packages '(:stumpwm-system))) + +(let ((*default-pathname-defaults* + (truename (sb-ext:posix-getenv "SBCL_HOME")))) + (sb-heapdump:dump-system :stumpwm)) +(sb-ext:quit) Added: trunk/scripts/makedeb-stumpwm ============================================================================== --- (empty file) +++ trunk/scripts/makedeb-stumpwm Sun May 28 14:26:45 2006 @@ -0,0 +1,21 @@ +#!/bin/sh -e +set -x +system=stumpwm + +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/stumpwm 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 Added: trunk/scripts/patches/stumpwm.diff ============================================================================== --- (empty file) +++ trunk/scripts/patches/stumpwm.diff Sun May 28 14:26:45 2006 @@ -0,0 +1,27 @@ +Index: stumpwm.asd +=================================================================== +RCS file: /cvsroot/stumpwm/stumpwm/stumpwm.asd,v +retrieving revision 1.8 +diff -u -u -r1.8 stumpwm.asd +--- stumpwm.asd 6 May 2006 19:28:16 -0000 1.8 ++++ stumpwm.asd 28 May 2006 18:21:15 -0000 +@@ -4,13 +4,14 @@ + (:use :cl :asdf)) + (in-package :stumpwm-system) + +-(ignore-errors (require :cmucl-clx)) +-(ignore-errors (require :clx)) +-;;(require :gray-streams) +- +-#+sbcl (require 'sb-posix) ++;;;(ignore-errors (require :cmucl-clx)) ++;;;(ignore-errors (require :clx)) ++;;;;;(require :gray-streams) ++;;; ++;;;#+sbcl (require 'sb-posix) + + (defsystem :stumpwm ++ :depends-on (:clx) + :name "StumpWM" + :author "Shawn Betts <sabetts(a)vcn.bc.ca>" + :version "0.0.3"

1 0

[steeldump-cvs] r8 - trunk/scripts/data
by dlichteblau＠common-lisp.net 28 May '06

28 May '06

Author: dlichteblau Date: Sun May 28 14:08:16 2006 New Revision: 8 Modified: trunk/scripts/data/clim-listener (props changed) trunk/scripts/data/eclipse (props changed) Log: fixed executable properties

1 0

[steeldump-cvs] r7 - in trunk/scripts: . data descriptions lisp patches
by dlichteblau＠common-lisp.net 28 May '06

28 May '06

Author: dlichteblau Date: Sun May 28 14:04:57 2006 New Revision: 7 Added: trunk/scripts/build-eclipse trunk/scripts/data/eclipse trunk/scripts/descriptions/eclipse trunk/scripts/fetch-SAMPLE (contents, props changed) trunk/scripts/fetch-eclipse (contents, props changed) trunk/scripts/lisp/build-eclipse.lisp trunk/scripts/makedeb-eclipse trunk/scripts/patches/eclipse.diff Modified: trunk/scripts/VERSION trunk/scripts/build-all trunk/scripts/fetch-all trunk/scripts/fetch-cl-ppcre trunk/scripts/fetch-flexi-streams trunk/scripts/fetch-sbcl trunk/scripts/lisp/build-cl-ppcre.lisp trunk/scripts/makedeb-all Log: version 2006-05-28 upgrade cl-ppcre to 1.2.14 upgrade flexi-streams to 0.5.5 new package eclipse Modified: trunk/scripts/VERSION ============================================================================== --- trunk/scripts/VERSION (original) +++ trunk/scripts/VERSION Sun May 28 14:04:57 2006 @@ -1 +1 @@ -2006-05-21 +2006-05-28 Modified: trunk/scripts/build-all ============================================================================== --- trunk/scripts/build-all (original) +++ trunk/scripts/build-all Sun May 28 14:04:57 2006 @@ -8,7 +8,7 @@ for system in climacs gsharp clx esa flexichain mcclim spatial-trees \ split-sequence cl-ppcre cl-fad tab-layout trivial-gray-streams \ - flexi-streams trivial-sockets cl-irc beirc + flexi-streams trivial-sockets cl-irc beirc eclipse do f=/opt/steeldump/lib/sbcl/${system}.heap if test -e $f; then Added: trunk/scripts/build-eclipse ============================================================================== --- (empty file) +++ trunk/scripts/build-eclipse Sun May 28 14:04:57 2006 @@ -0,0 +1,4 @@ +#!/bin/sh -e +set -x +touch /opt/steeldump/src/eclipse/config.lisp +/opt/steeldump/scripts/aux/build-system eclipse Added: trunk/scripts/data/eclipse ============================================================================== --- (empty file) +++ trunk/scripts/data/eclipse Sun May 28 14:04:57 2006 @@ -0,0 +1,56 @@ +#! /bin/sh +# $Id: eclipse.in,v 1.10 2005/02/10 23:45:44 ihatchondo Exp $ +# +# This file starts the eclipse window manager +# +# Modified for steeldump. +unset SBCL_HOME + +usage () { + printf "\nusage: eclipse [options]\n\n" + printf " --display=dpy specifies the X server to use.\n" + printf " --sm-client-id=id specifies the sesion manager id to use.\n" + printf " --activate-log specifies that errors must be logged.\n\n" + exit 1; +} + +display_spec="" +sm_client_id="" +activate_log="" +options="" + +## Parse and collect options. + +if [ $# -gt 3 ] ; then usage ; fi + +while [ $# -gt 0 ] ; do + case "$1" in + --display=*) + tmp=`echo $1 | cut -d'=' -f2` + display_spec=":display \"$tmp\"" ; + shift ; + ;; + --sm-client-id=*) + tmp=`echo $1 | cut -d'=' -f2` + sm_client_id=":sm-client-id \"$tmp\""; + shift ; + ;; + --activate-log) + activate_log=":activate-log t"; + shift ; + ;; + -* | *) + printf "\n $1 unknow option \n"; + usage ;; + esac +done + +options="$display_spec $sm_client_id $activate_log" + +exec /opt/steeldump/bin/sbcl \ + --noinform \ + --userinit /dev/null \ + --disable-debugger \ + --eval '(setf sb-heapdump:*dumpload-verbose* nil)' \ + --eval '(require :eclipse)' \ + --eval "(progn (eclipse:eclipse ${options}) (sb-ext:quit))" Added: trunk/scripts/descriptions/eclipse ============================================================================== --- (empty file) +++ trunk/scripts/descriptions/eclipse Sun May 28 14:04:57 2006 @@ -0,0 +1,8 @@ +Description: A window manager written entirely in Common Lisp. (steeldump package) + Eclipse is a window manager written entirely in Common Lisp. Started + by a group of students of the 4th year CS program in Bordeaux, France, + as part of their second-semester programming project. Currently the + window manager is being maintained by one of those students, Iban + Hatchondo, as well as several other Common Lisp programmers. + . + This is a non-Debian binary package from the steeldump repository. Added: trunk/scripts/fetch-SAMPLE ============================================================================== --- (empty file) +++ trunk/scripts/fetch-SAMPLE Sun May 28 14:04:57 2006 @@ -0,0 +1,19 @@ +#!/bin/sh -e +set -x + +# choose one: + +/opt/steeldump/scripts/aux/fetch-url \ + z \ + http://acme.com/pub/SAMPLE/ \ + SAMPLE.tar.gz \ + SAMPLE-1.2 \ + SAMPLE + +/opt/steeldump/scripts/aux/fetch-svn \ + svn://common-lisp.net/project/SAMPLE/svn/trunk \ + SAMPLE + +/opt/steeldump/scripts/aux/fetch-cvs \ + :pserver:anonymous:anonymous@common-lisp.net:/project/SAMPLE/cvsroot \ + SAMPLE Modified: trunk/scripts/fetch-all ============================================================================== --- trunk/scripts/fetch-all (original) +++ trunk/scripts/fetch-all Sun May 28 14:04:57 2006 @@ -1,7 +1,7 @@ #!/bin/sh -e for system in sbcl clx esa flexichain mcclim spatial-trees split-sequence \ climacs gsharp cl-ppcre cl-fad tab-layout trivial-gray-streams \ - flexi-streams trivial-sockets cl-irc beirc + flexi-streams trivial-sockets cl-irc beirc eclipse do if test -e /opt/steeldump/src/$system; then echo "$system already present, skipping" Modified: trunk/scripts/fetch-cl-ppcre ============================================================================== --- trunk/scripts/fetch-cl-ppcre (original) +++ trunk/scripts/fetch-cl-ppcre Sun May 28 14:04:57 2006 @@ -4,5 +4,5 @@ z \ http://weitz.de/files/ \ cl-ppcre.tar.gz \ - cl-ppcre-1.2.13 \ + cl-ppcre-1.2.14 \ cl-ppcre Added: trunk/scripts/fetch-eclipse ============================================================================== --- (empty file) +++ trunk/scripts/fetch-eclipse Sun May 28 14:04:57 2006 @@ -0,0 +1,7 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/fetch-cvs \ + :pserver:anonymous:anonymous@common-lisp.net:/project/eclipse/cvsroot \ + eclipse +cd /opt/steeldump/src/eclipse +patch -p0 </opt/steeldump/scripts/patches/eclipse.diff Modified: trunk/scripts/fetch-flexi-streams ============================================================================== --- trunk/scripts/fetch-flexi-streams (original) +++ trunk/scripts/fetch-flexi-streams Sun May 28 14:04:57 2006 @@ -4,5 +4,5 @@ z \ http://weitz.de/files/ \ flexi-streams.tar.gz \ - flexi-streams-0.5.4 \ + flexi-streams-0.5.5 \ flexi-streams Modified: trunk/scripts/fetch-sbcl ============================================================================== --- trunk/scripts/fetch-sbcl (original) +++ trunk/scripts/fetch-sbcl Sun May 28 14:04:57 2006 @@ -7,8 +7,8 @@ ./scripts/aux/fetch-url \ j \ $mirror/sbcl/ \ - sbcl-0.9.12-source.tar.bz2 \ - sbcl-0.9.12 \ + sbcl-0.9.13-source.tar.bz2 \ + sbcl-0.9.13 \ sbcl ./scripts/aux/fetch-svn \ svn://common-lisp.net/project/steeldump/svn/trunk/sb-heapdump \ Modified: trunk/scripts/lisp/build-cl-ppcre.lisp ============================================================================== --- trunk/scripts/lisp/build-cl-ppcre.lisp (original) +++ trunk/scripts/lisp/build-cl-ppcre.lisp Sun May 28 14:04:57 2006 @@ -9,7 +9,7 @@ "cl-ppcre.heap" :if-exists :rename-and-delete :systems '(:cl-ppcre) - :system-packages '(:cl-ppcre.system))) + :system-packages '())) (let ((*default-pathname-defaults* (truename (sb-ext:posix-getenv "SBCL_HOME")))) Added: trunk/scripts/lisp/build-eclipse.lisp ============================================================================== --- (empty file) +++ trunk/scripts/lisp/build-eclipse.lisp Sun May 28 14:04:57 2006 @@ -0,0 +1,37 @@ +(sb-ext:disable-debugger) +(setf asdf:*central-registry* (list (car asdf:*central-registry*))) + +(asdf:operate 'asdf:load-op :clx) +(load "/opt/steeldump/src/eclipse/system.lisp") +(asdf:operate 'asdf:load-op :eclipse) +(defparameter eclipse:*eclipse-eclipsedir* nil) +(defparameter eclipse:*eclipse-initfile* ".eclipse") + +(defmethod sb-heapdump:dump-system + ((c (eql (asdf:find-system :eclipse)))) + (sb-heapdump:dump-packages + '(;; "COOLCLEAN-ECLIPSE-THEME" "BRUSHED-METAL-ECLIPSE-THEME" + ;; "STEP-ECLIPSE-THEME" "MICROGUI-ECLIPSE-THEME" + "NO-DECORATION-ECLIPSE-THEME" "ECLIPSE-EXTENSIONS" "ECLIPSE-INTERNALS" + "PROGRAMMED-TASKS" "KEYBOARD" "CLX-EXTENSIONS" "GNOME" + "EXTENDED-WINDOW-MANAGER-HINTS" "MANAGER-COMMONS" "PPM" "SM-LIB" + "ICE-LIB") + "eclipse.heap" + :initializer (lambda (foo) + (load "/opt/steeldump/src/eclipse/lib/clx-ext/clx-patch.fasl") + foo) + :if-exists :rename-and-delete + :systems '(:sm-lib :eclipse-lisp :clx-ext :eclipse-lib :eclipse :ice-lib) + :system-packages '("ECLIPSE-SYSTEM" "SM-LIB-SYSTEM" "ICE-LIB-SYSTEM"))) + +(let ((*default-pathname-defaults* + (truename (sb-ext:posix-getenv "SBCL_HOME")))) + (sb-heapdump:dump-system :eclipse)) + +(eclipse-system:compile-themes + "/opt/steeldump/src/eclipse/themes/microGUI/" + "/opt/steeldump/src/eclipse/themes/Step/" + "/opt/steeldump/src/eclipse/themes/brushed-metal/" + "/opt/steeldump/src/eclipse/themes/CoolClean/") + +(sb-ext:quit) Modified: trunk/scripts/makedeb-all ============================================================================== --- trunk/scripts/makedeb-all (original) +++ trunk/scripts/makedeb-all Sun May 28 14:04:57 2006 @@ -22,3 +22,4 @@ /opt/steeldump/scripts/makedeb-trivial-sockets /opt/steeldump/scripts/makedeb-cl-irc /opt/steeldump/scripts/makedeb-beirc +/opt/steeldump/scripts/makedeb-eclipse Added: trunk/scripts/makedeb-eclipse ============================================================================== --- (empty file) +++ trunk/scripts/makedeb-eclipse Sun May 28 14:04:57 2006 @@ -0,0 +1,22 @@ +#!/bin/sh -e +set -x +system=eclipse + +cd /opt/steeldump + +rm -rf SCRATCH +mkdir SCRATCH + +tar cf - \ + /opt/steeldump/lib/sbcl/${system}.heap \ + /opt/steeldump/src/$system \ + | tar C SCRATCH -xpf - + +mkdir SCRATCH/opt/steeldump/bin +cp /opt/steeldump/scripts/data/eclipse SCRATCH/opt/steeldump/bin/ + +HACK=/opt/steeldump/src/eclipse/lib/clx-ext/clx-patch.fasl +/opt/steeldump/scripts/aux/wipe-fasls $system +cp $HACK /opt/steeldump/SCRATCH/$HACK +/opt/steeldump/scripts/aux/write-dummy-asd $system +/opt/steeldump/scripts/aux/makedeb-helper $system sbcl clx Added: trunk/scripts/patches/eclipse.diff ============================================================================== --- (empty file) +++ trunk/scripts/patches/eclipse.diff Sun May 28 14:04:57 2006 @@ -0,0 +1,74 @@ +Index: eclipse.lisp +=================================================================== +RCS file: /project/eclipse/cvsroot/eclipse/eclipse.lisp,v +retrieving revision 1.25 +diff -u -u -r1.25 eclipse.lisp +--- eclipse.lisp 14 Jan 2006 15:40:55 -0000 1.25 ++++ eclipse.lisp 28 May 2006 18:02:31 -0000 +@@ -185,7 +185,7 @@ + :line-width 1 :exposures :OFF)) + ;; load personal configuration file, or the default one. + (labels ((load-if (f) (and (probe-file f) (load-config-file f)))) +- (or (load-if (home-subdirectory cl-user::*eclipse-initfile*)) ++ (or (load-if (home-subdirectory *eclipse-initfile*)) + (load-if (eclipse-path "eclipserc")) + (error "Unable to read a configuration file.~%"))) + (setf (xlib:window-cursor root-window) (root-default-cursor *root*)) +Index: global.lisp +=================================================================== +RCS file: /project/eclipse/cvsroot/eclipse/global.lisp,v +retrieving revision 1.29 +diff -u -u -r1.29 global.lisp +--- global.lisp 1 Mar 2005 22:41:31 -0000 1.29 ++++ global.lisp 28 May 2006 18:02:32 -0000 +@@ -24,7 +24,7 @@ + + (defun eclipse-path (&rest names) + (apply #'concatenate 'string +- (or cl-user::*eclipse-eclipsedir* *eclipse-directory*) ++ (or *eclipse-eclipsedir* *eclipse-directory*) + names)) + + ;; The two following constants represent all the gnome protocols +@@ -214,6 +214,7 @@ + (format *stderr* + "X error ~A ~:[~;with id~]~%=> ~{~A ~}~%" + err resource-id keys) ++ (cl-user::backtrace) + (when resource-id + (let* ((resource (xlib::lookup-window dpy resource-id)) + (widget (lookup-widget resource))) +Index: package.lisp +=================================================================== +RCS file: /project/eclipse/cvsroot/eclipse/package.lisp,v +retrieving revision 1.19 +diff -u -u -r1.19 package.lisp +--- package.lisp 16 Jan 2005 23:25:59 -0000 1.19 ++++ package.lisp 28 May 2006 18:02:32 -0000 +@@ -363,6 +363,10 @@ + #:*verbose-resize* + #:*verbose-window-cycling* + #:*warp-pointer-when-cycle* ++ ++ ;; added for steeldump: ++ #:*eclipse-eclipsedir* ++ #:*eclipse-initfile* + )) + + (defpackage ECLIPSE-EXTENSIONS +Index: system.lisp +=================================================================== +RCS file: /project/eclipse/cvsroot/eclipse/system.lisp,v +retrieving revision 1.16 +diff -u -u -r1.16 system.lisp +--- system.lisp 13 Mar 2005 23:37:06 -0000 1.16 ++++ system.lisp 28 May 2006 18:02:32 -0000 +@@ -109,7 +109,7 @@ + (eclipse-defsystem (:eclipse-lisp) + #+:clisp "lisp-dep/clisp.lisp") + +-(eclipse-defsystem (:clx-ext :depends-on (:eclipse-lisp)) ++(eclipse-defsystem (:clx-ext :depends-on (:eclipse-lisp :clx)) + "lib/clx-ext/clx-patch.lisp" + "lib/clx-ext/xvidmode.lisp" + "lib/clx-ext/package.lisp"

1 0

[steeldump-cvs] r6 - trunk/steeldump-web
by dlichteblau＠common-lisp.net 28 May '06

28 May '06

Author: dlichteblau Date: Sun May 28 11:03:59 2006 New Revision: 6 Modified: trunk/steeldump-web/index.html trunk/steeldump-web/steeldump.css Log: added version numbers Modified: trunk/steeldump-web/index.html ============================================================================== --- trunk/steeldump-web/index.html (original) +++ trunk/steeldump-web/index.html Sun May 28 11:03:59 2006 @@ -31,7 +31,7 @@ </a> </li> <li> - <a href="http://common-lisp.net/websvn/listing.php?repname=steeldump&path=%2F&sc=0"> + <a href="http://common-lisp.net/websvn/listing.php?repname=steeldump&path=%2F&am…"> Browse SVN </a> </li> @@ -41,76 +41,145 @@ steeldumped applications </div> <div class="sidebar-main"> - <ul> - <li> - <a href="http://common-lisp.net/project/beirc">beirc</a> - <sub> from CVS</sub> - </li> - <li> - <a href="http://common-lisp.net/project/climacs">climacs</a> - <sub> from CVS</sub> - </li> - <li> - <a href="http://common-lisp.net/project/gsharp">gsharp</a> - <sub> from CVS</sub> - </li> - </ul> + <table width="100%" style="list-style: inside"> + <tr> + <td> + <li><a href="http://common-lisp.net/project/beirc">beirc</a></li> + </td> + <td align="right"> + <sub>CVS</sub> + </td> + </tr> + <tr> + <td> + <li><a href="http://common-lisp.net/project/climacs">climacs</a></li> + </td> + <td align="right"> + <sub>CVS</sub> + </td> + </tr> + <tr> + <td> + <li><a href="http://common-lisp.net/project/gsharp">gsharp</a></li> + </td> + <td align="right"> + <sub>CVS</sub> + </td> + </tr> + </table> </div> <div class="sidebar-title"> steeldumped libraries </div> <div class="sidebar-main"> - <ul> - <li> - <a href="http://weitz.de/cl-fad/">cl-fad</a> - <sub> 0.5.0</sub> - </li> - <li> - <a href="http://common-lisp.net/project/cl-irc">cl-irc</a> - <sub> from SVN</sub> - </li> - <li> - <a href="http://weitz.de/cl-ppcre/">cl-ppcre</a> - <sub> 1.2.14</sub> - </li> - <li> - <a href="http://common-lisp.net/project/climacs">esa</a> - <sub> from CVS</sub> - (<a href="http://www.cliki.net/esa">about</a>) - </li> - <li> - <a href="http://www.cliki.net/CLX">clx</a> - <sub> 0.7.3</sub> - </li> - <li> - <a href="http://weitz.de/flexi-streams/">flexi-streams</a> - <sub> 0.5.5</sub> - </li> - <li> - <a href="http://common-lisp.net/project/flexichain">flexichain</a> - <sub> from CVS</sub> - </li> - <li> - <a href="http://common-lisp.net/project/mcclim">McCLIM</a> - <sub> from CVS</sub> - </li> - <li> - <a href="http://www.cliki.net/spatial-trees">spatial-trees</a> - <sub> 0.2</sub> - </li> - <li> - <a href="http://www.cliki.net/split-sequence">split-sequence</a> - </li> - <li>tab-layout</li> - <li> - <a href="http://common-lisp.net/project/cl-plus-ssl#trivial-gray-streams">trivial-gray-streams</a> - <sub> from CVS</sub> - </li> - <li> - <a href="http://www.cliki.net/trivial-sockets">trivial-sockets</a> - <sub> 0.3</sub> - </li> - </ul> + <table width="100%" style="list-style: inside"> + <tr> + <td> + <li><a href="http://weitz.de/cl-fad/">cl-fad</a></li> + </td> + <td align="right"> + <sub>0.5.0</sub> + </td> + </tr> + <tr> + <td> + <li><a href="http://common-lisp.net/project/cl-irc">cl-irc</a></li> + </td> + <td align="right"> + <sub>SVN</sub> + </td> + </tr> + <tr> + <td> + <li><a href="http://weitz.de/cl-ppcre/">cl-ppcre</a></li> + </td> + <td align="right"> + <sub>1.2.14</sub> + </td> + </tr> + <tr> + <td> + <li><a href="http://common-lisp.net/project/climacs">esa</a> + (<a href="http://www.cliki.net/esa">about</a>) + </li> + </td> + <td align="right"> + <sub>CVS</sub> + </td> + </tr> + <tr> + <td> + <li><a href="http://www.cliki.net/CLX">clx</a></li> + </td> + <td align="right"> + <sub>0.7.3</sub> + </td> + </tr> + <tr> + <td> + <li><a href="http://weitz.de/flexi-streams/">flexi-streams</a></li> + </td> + <td align="right"> + <sub>0.5.5</sub> + </td> + </tr> + <tr> + <td> + <li><a href="http://common-lisp.net/project/flexichain">flexichain</a></li> + </td> + <td align="right"> + <sub>CVS</sub> + </td> + </tr> + <tr> + <td> + <li><a href="http://common-lisp.net/project/mcclim">McCLIM</a></li> + </td> + <td align="right"> + <sub>CVS</sub> + </td> + </tr> + <tr> + <td> + <li><a href="http://www.cliki.net/spatial-trees">spatial-trees</a></li> + </td> + <td align="right"> + <sub>0.2</sub> + </td> + </tr> + <tr> + <td> + <li><a href="http://www.cliki.net/split-sequence">split-sequence</a></li> + </td> + <td align="right"> + <sub>20011114.1</sub> + </td> + </tr> + <tr> + <td> + <li>tab-layout</li> + </td> + <td align="right"> + <sub>2005-09-19</sub> + </td> + </tr> + <tr> + <td> + <li><a href="http://common-lisp.net/project/cl-plus-ssl#trivial-gray-streams">trivial-gray-streams</a></li> + </td> + <td align="right"> + <sub>CVS</sub> + </td> + </tr> + <tr> + <td> + <li><a href="http://www.cliki.net/trivial-sockets">trivial-sockets</a></li> + </td> + <td align="right"> + <sub>0.3</sub> + </td> + </tr> + </table> </div> </div> Modified: trunk/steeldump-web/steeldump.css ============================================================================== --- trunk/steeldump-web/steeldump.css (original) +++ trunk/steeldump-web/steeldump.css Sun May 28 11:03:59 2006 @@ -1,6 +1,6 @@ div.sidebar { float: right; - min-width: 15%; + width: 30%; padding: 0pt 5pt 5pt 5pt; font-family: verdana, arial; }

1 0

[steeldump-cvs] r5 - trunk/steeldump-web
by dlichteblau＠common-lisp.net 28 May '06

28 May '06

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 @@ +<?xml version="1.0" encoding="iso-8859-1"?> +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en"> + <head> + <title>Steeldump</title> + <link rel="stylesheet" type="text/css" href="steeldump.css"/> + </head> + <body> + <div class="sidebar"> + <div class="sidebar-title"> + about steeldump + </div> + <div class="sidebar-main" style="padding-bottom: 1px"> + <ul> + <li> + <a href="index.html">Main page:</a> + <ul class="sub"> + <li><a href="index.html#installation">Installation</a></li> + <li><a href="index.html#usage">Usage</a></li> + <li><a href="index.html#bugs">How to report problems</a></li> + </ul> + Development: + <ul class="sub"> + <li><a href="building.html">Building Steeldump</a></li> + <li><a href="#extending">Extending Steeldump</a></li> + </ul> + </li> + <li> + <a href="http://common-lisp.net/cgi-bin/mailman/listinfo/steeldump-devel"> + steeldump-devel(a)common-lisp.net + </a> + </li> + <li> + <a href="http://common-lisp.net/websvn/listing.php?repname=steeldump&path=%2F&sc=0"> + Browse SVN + </a> + </li> + </ul> + </div> + </div> + + <h1>Steeldump<sub style="font-weight: normal; font-size: 10pt; color: #009c00">BETA</sub></h1> + + <h3> + Building Steeldump + <a name="building"></a> + </h3> + <p> + (You can skip this section if you just want to use steeldump + packages normally. See above for installation instructions.) + </p> + <p> + To help debugging or developing Steeldump, the following steps + should be enough to build your own steeldump packages: + </p> + <ul> + <li> + Set up a chroot environment or virtual machine to compile + steeldump in. + <br/> + <br/> + If you really do not want to do this, keep this in mind: + Steeldump <i>must</i> be compiled in the exact same location + where it is going to be installed into, + <tt>/opt/steeldump</tt>. So you cannot run the steeldump + scripts in a filesystem where steeldump packages are already + installed. + <br/> + <br/> + Although it does not address safety issues, you can obviously + build a mock-up chroot very easily using <tt>mount -o bind</tt>, + so this should not be too much of an issue. + </li> + <li> + Create a new directory <tt>/opt/steeldump</tt>. In the build + environment, this directory should be owned by a non-root user. + (The build scripts will only run <tt>sudo</tt> briefly for each + package to fix file ownership before packaging the files up. + Building should be done normally under your non-root account.) + </li> + <li> + Check out the steeldump scripts from Subversion: + <pre>$ cd /opt/steeldump +$ svn co svn://common-lisp.net/project/steeldump/svn/trunk/scripts</pre> + </li> + <li> + Run the first script: + <pre>/opt/steeldump$ ./scripts/init</pre> + -- 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. + </li> + <li> + The first package you need to download and build is SBCL: + <pre>$ ./scripts/fetch-sbcl +$ ./scripts/build-sbcl +$ ./scripts/makedeb-sbcl</pre> + </li> + </ul> + <p> + Congratulations: If that worked, you have your first .deb package in + <tt>/opt/steeldump/pool</tt>. + </p> + <ul> + <li> + Now you can build the actual steeldumped applications using the + same steps: + <pre>$ ./scripts/fetch-all +$ ./scripts/build-all +$ ./scripts/makedeb-all</pre> + </li> + </ul> + <p> + And that's it. After makedeb-all, you can find all packages in + the <tt>pool</tt> directory. + </p> + <p> + While debugging, however, you will probably want to build + individual packages instead of all in one go: + </p> + <ul> + <li> + For every system, there is a separate <tt>fetch-</tt><i>foo</i> + script. These fetch-scripts do <i>not</i> track dependencies + for you. When not using <tt>fetch-all</tt>, make sure to + download everything you need before trying to build. + </li> + <li> + The <tt>build-</tt><i>foo</i> scripts can be invoked in an + arbitrary order. For example, building climacs will + automatically compile mcclim if it had not been compiled + yet. <i>However</i>, it does not actually create the dumpfile + for mcclim, you will still have to call <tt>build-mcclim</tt> + eventually before you can make its .deb file. + </li> + <li> + Finally, for <tt>makedeb-all</tt> note that it has one advantage + over the individual <tt>makedeb-</tt><i>foo</i> scripts: Before + calling out to the others, <tt>makedeb-all</tt> relocates the + heap files to non-overlapping locations, speeding up loading of + the heap files a little. + </li> + </ul> + <p> + If you got this far and have working packages in + <tt>/opt/steeldump/pool</tt>, send me a postcard. + </p> + + <h3> + Extending Steeldump + <a name="extending"></a> + </h3> + <p> + (You can skip this section if you just want to use steeldump + packages normally. See above for installation instructions.) + </p> + <p> + To add a new package called "blubba", create these files: + </p> + <ul> + <li> + <tt>/opt/steeldump/scripts/fetch-blubba</tt><br/> + This script must put the source code into + <tt>/opt/steeldump/src/blubba</tt>. Remove version numbers from + the directory name, if any.<br/> + Look at the other fetch scripts for ideas. Usually it is enough + to call one of the helper scripts, <tt>aux/fetch-url</tt>, + <tt>aux/fetch-cvs</tt>, or <tt>aux/fetch-svn</tt>. If you have + to patch the source code, this script is the right place to do + that. + </li> + <li> + <tt>/opt/steeldump/scripts/build-blubba</tt><br/> + Usually this script is trivial and just + calls <tt>build-system</tt>. Copy + over <tt>/opt/steeldump/scripts/build-SAMPLE</tt> and change the + system name from "SAMPLESSYTEMNAME" to "blubba". This script + is the right place to call "make" if the system includes C code. + </li> + <li> + <tt>/opt/steeldump/scripts/lisp/build-blubba.lisp</tt><br/> + This Lisp script is less trivial. Starting from the sample file + <tt>/opt/steeldump/scripts/lisp/build-SAMPLE.lisp</tt>, change + the system name from "SAMPLE" to "blubba", but review the + heap dumping logic carefully. The heap dumper needs to be told + about: + <ul> + <li> + The packages that are to be dumped (look out for multiple + defpackage forms). This is the first argument + to <tt>dump-system</tt>. + </li> + <li> + The ASDF systems involved. If the .asd file contains + multiple system definitions, all of them must be listed + manually in the build script. (The <tt>:system</tt> + argument.) + </li> + <li> + The name of the package the .asd files defines and uses. + (The <tt>:system-package</tt> argument.) + </li> + </ul> + You now have a first draft of the dumping script. Beware that + <em>dumping</em> 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 <em>other</em> packages, slots of objects the heap dumper + cannot know about, etc. + <ul> + <li> + Refer to sb-heapdump documentation on the precise logic used + by the dumper. + </li> + <li> + 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. + </li> + <li> + 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. + </li> + </ul> + </li> + <li> + <tt>/opt/steeldump/scripts/descriptions/blubba</tt><br/> + This file ends up as the <tt>Description:</tt> header in the + Debian package's <tt>control</tt> file. + Again there is a skeleton file: + <tt>/opt/steeldump/scripts/descriptions/SAMPLE</tt>. + </li> + <li> + <tt>/opt/steeldump/scripts/makedeb-blubba</tt><br/> + This scripts collect all files to be installed and creates the + .deb archive. Starting + with <tt>/opt/steeldump/scripts/makedeb-SAMPLE</tt>, + 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. + </li> + </ul> + </body> +</html> 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 @@ <li><a href="#installation">Installation</a></li> <li><a href="#usage">Usage</a></li> <li><a href="#bugs">How to report problems</a></li> - <li><a href="#building">Building Steeldump</a></li> - <li><a href="#extending">Extending Steeldump</a></li> + </ul> + Development: + <ul class="sub"> + <li><a href="building.html">Building Steeldump</a></li> + <li><a href="building.html#extending">Extending Steeldump</a></li> </ul> </li> <li> @@ -39,9 +42,18 @@ </div> <div class="sidebar-main"> <ul> - <li><a href="http://common-lisp.net/project/beirc">beirc</a></li> - <li><a href="http://common-lisp.net/project/climacs">climacs</a></li> - <li><a href="http://common-lisp.net/project/gsharp">gsharp</a></li> + <li> + <a href="http://common-lisp.net/project/beirc">beirc</a> + <sub> from CVS</sub> + </li> + <li> + <a href="http://common-lisp.net/project/climacs">climacs</a> + <sub> from CVS</sub> + </li> + <li> + <a href="http://common-lisp.net/project/gsharp">gsharp</a> + <sub> from CVS</sub> + </li> </ul> </div> <div class="sidebar-title"> @@ -49,22 +61,55 @@ </div> <div class="sidebar-main"> <ul> - <li><a href="http://weitz.de/cl-fad/">cl-fad</a></li> - <li><a href="http://common-lisp.net/project/cl-irc">cl-irc</a></li> - <li><a href="http://weitz.de/cl-ppcre/">cl-ppcre</a></li> + <li> + <a href="http://weitz.de/cl-fad/">cl-fad</a> + <sub> 0.5.0</sub> + </li> + <li> + <a href="http://common-lisp.net/project/cl-irc">cl-irc</a> + <sub> from SVN</sub> + </li> + <li> + <a href="http://weitz.de/cl-ppcre/">cl-ppcre</a> + <sub> 1.2.14</sub> + </li> <li> <a href="http://common-lisp.net/project/climacs">esa</a> + <sub> from CVS</sub> (<a href="http://www.cliki.net/esa">about</a>) </li> - <li><a href="http://www.cliki.net/CLX">clx</a></li> - <li><a href="http://weitz.de/flexi-streams/">flexi-streams</a></li> - <li><a href="http://common-lisp.net/project/flexichain">flexichain</a></li> - <li><a href="http://common-lisp.net/project/mcclim">McCLIM</a></li> - <li><a href="http://www.cliki.net/spatial-trees">spatial-trees</a></li> - <li><a href="http://www.cliki.net/split-sequence">split-sequence</a></li> + <li> + <a href="http://www.cliki.net/CLX">clx</a> + <sub> 0.7.3</sub> + </li> + <li> + <a href="http://weitz.de/flexi-streams/">flexi-streams</a> + <sub> 0.5.5</sub> + </li> + <li> + <a href="http://common-lisp.net/project/flexichain">flexichain</a> + <sub> from CVS</sub> + </li> + <li> + <a href="http://common-lisp.net/project/mcclim">McCLIM</a> + <sub> from CVS</sub> + </li> + <li> + <a href="http://www.cliki.net/spatial-trees">spatial-trees</a> + <sub> 0.2</sub> + </li> + <li> + <a href="http://www.cliki.net/split-sequence">split-sequence</a> + </li> <li>tab-layout</li> - <li><a href="http://common-lisp.net/project/cl-plus-ssl#trivial-gray-streams">trivial-gray-streams</a></li> - <li><a href="http://www.cliki.net/trivial-sockets">trivial-sockets</a></li> + <li> + <a href="http://common-lisp.net/project/cl-plus-ssl#trivial-gray-streams">trivial-gray-streams</a> + <sub> from CVS</sub> + </li> + <li> + <a href="http://www.cliki.net/trivial-sockets">trivial-sockets</a> + <sub> 0.3</sub> + </li> </ul> </div> </div> @@ -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. </p> - - <h3> - Building Steeldump - <a name="building"></a> - </h3> - <p> - (You can skip this section if you just want to use steeldump - packages normally. See above for installation instructions.) - </p> - <p> - To help debugging or developing Steeldump, the following steps - should be enough to build your own steeldump packages: - </p> - <ul> - <li> - Set up a chroot environment or virtual machine to compile - steeldump in. - <br/> - <br/> - If you really do not want to do this, keep this in mind: - Steeldump <i>must</i> be compiled in the exact same location - where it is going to be installed into, - <tt>/opt/steeldump</tt>. So you cannot run the steeldump - scripts in a filesystem where steeldump packages are already - installed. - <br/> - <br/> - Although it does not address safety issues, you can obviously - build a mock-up chroot very easily using <tt>mount -o bind</tt>, - so this should not be too much of an issue. - </li> - <li> - Create a new directory <tt>/opt/steeldump</tt>. In the build - environment, this directory should be owned by a non-root user. - (The build scripts will only run <tt>sudo</tt> briefly for each - package to fix file ownership before packaging the files up. - Building should be done normally under your non-root account.) - </li> - <li> - Check out the steeldump scripts from Subversion: - <pre>$ cd /opt/steeldump -$ svn co svn://common-lisp.net/project/steeldump/svn/trunk/scripts</pre> - </li> - <li> - Run the first script: - <pre>/opt/steeldump$ ./scripts/init</pre> - -- 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. - </li> - <li> - The first package you need to download and build is SBCL: - <pre>$ ./scripts/fetch-sbcl -$ ./scripts/build-sbcl -$ ./scripts/makedeb-sbcl</pre> - </li> - </ul> - <p> - Congratulations: If that worked, you have your first .deb package in - <tt>/opt/steeldump/pool</tt>. - </p> - <ul> - <li> - Now you can build the actual steeldumped applications using the - same steps: - <pre>$ ./scripts/fetch-all -$ ./scripts/build-all -$ ./scripts/makedeb-all</pre> - </li> - </ul> - <p> - And that's it. After makedeb-all, you can find all packages in - the <tt>pool</tt> directory. - </p> - <p> - While debugging, however, you will probably want to build - individual packages instead of all in one go: - </p> - <ul> - <li> - For every system, there is a separate <tt>fetch-</tt><i>foo</i> - script. These fetch-scripts do <i>not</i> track dependencies - for you. When not using <tt>fetch-all</tt>, make sure to - download everything you need before trying to build. - </li> - <li> - The <tt>build-</tt><i>foo</i> scripts can be invoked in an - arbitrary order. For example, building climacs will - automatically compile mcclim if it had not been compiled - yet. <i>However</i>, it does not actually create the dumpfile - for mcclim, you will still have to call <tt>build-mcclim</tt> - eventually before you can make its .deb file. - </li> - <li> - Finally, for <tt>makedeb-all</tt> note that it has one advantage - over the individual <tt>makedeb-</tt><i>foo</i> scripts: Before - calling out to the others, <tt>makedeb-all</tt> relocates the - heap files to non-overlapping locations, speeding up loading of - the heap files a little. - </li> - </ul> - <p> - If you got this far and have working packages in - <tt>/opt/steeldump/pool</tt>, send me a postcard. - </p> - - <h3> - Extending Steeldump - <a name="extending"></a> - </h3> - <p> - (You can skip this section if you just want to use steeldump - packages normally. See above for installation instructions.) - </p> - <p> - To add a new package called "blubba", create these files: - </p> - <ul> - <li> - <tt>/opt/steeldump/scripts/fetch-blubba</tt><br/> - This script must put the source code into - <tt>/opt/steeldump/src/blubba</tt>. Remove version numbers from - the directory name, if any.<br/> - Look at the other fetch scripts for ideas. Usually it is enough - to call one of the helper scripts, <tt>aux/fetch-url</tt>, - <tt>aux/fetch-cvs</tt>, or <tt>aux/fetch-svn</tt>. If you have - to patch the source code, this script is the right place to do - that. - </li> - <li> - <tt>/opt/steeldump/scripts/build-blubba</tt><br/> - Usually this script is trivial and just - calls <tt>build-system</tt>. Copy - over <tt>/opt/steeldump/scripts/build-SAMPLE</tt> and change the - system name from "SAMPLESSYTEMNAME" to "blubba". This script - is the right place to call "make" if the system includes C code. - </li> - <li> - <tt>/opt/steeldump/scripts/lisp/build-blubba.lisp</tt><br/> - This Lisp script is less trivial. Starting from the sample file - <tt>/opt/steeldump/scripts/lisp/build-SAMPLE.lisp</tt>, change - the system name from "SAMPLE" to "blubba", but review the - heap dumping logic carefully. The heap dumper needs to be told - about: - <ul> - <li> - The packages that are to be dumped (look out for multiple - defpackage forms). This is the first argument - to <tt>dump-system</tt>. - </li> - <li> - The ASDF systems involved. If the .asd file contains - multiple system definitions, all of them must be listed - manually in the build script. (The <tt>:system</tt> - argument.) - </li> - <li> - The name of the package the .asd files defines and uses. - (The <tt>:system-package</tt> argument.) - </li> - </ul> - You now have a first draft of the dumping script. Beware that - <em>dumping</em> 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 <em>other</em> packages, slots of objects the heap dumper - cannot know about, etc. - <ul> - <li> - Refer to sb-heapdump documentation on the precise logic used - by the dumper. - </li> - <li> - 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. - </li> - <li> - 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. - </li> - </ul> - </li> - <li> - <tt>/opt/steeldump/scripts/descriptions/blubba</tt><br/> - This file ends up as the <tt>Description:</tt> header in the - Debian package's <tt>control</tt> file. - Again there is a skeleton file: - <tt>/opt/steeldump/scripts/descriptions/SAMPLE</tt>. - </li> - <li> - <tt>/opt/steeldump/scripts/makedeb-blubba</tt><br/> - This scripts collect all files to be installed and creates the - .deb archive. Starting - with <tt>/opt/steeldump/scripts/makedeb-SAMPLE</tt>, - 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. - </li> - </ul> </body> </html>

1 0

[steeldump-cvs] r4 - trunk/steeldump-web
by dlichteblau＠common-lisp.net 21 May '06

21 May '06

Author: dlichteblau Date: Sun May 21 14:33:08 2006 New Revision: 4 Added: trunk/steeldump-web/ trunk/steeldump-web/bg.png (contents, props changed) trunk/steeldump-web/index.html trunk/steeldump-web/steeldump.css Log: web pages Added: trunk/steeldump-web/bg.png ============================================================================== Binary file. No diff available. Added: trunk/steeldump-web/index.html ============================================================================== --- (empty file) +++ trunk/steeldump-web/index.html Sun May 21 14:33:08 2006 @@ -0,0 +1,425 @@ +<?xml version="1.0" encoding="iso-8859-1"?> +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en"> + <head> + <title>Steeldump</title> + <link rel="stylesheet" type="text/css" href="steeldump.css"/> + </head> + <body> + <div class="sidebar"> + <div class="sidebar-title"> + about steeldump + </div> + <div class="sidebar-main" style="padding-bottom: 1px"> + <ul> + <li> + On this page: + <ul class="sub"> + <li><a href="#installation">Installation</a></li> + <li><a href="#usage">Usage</a></li> + <li><a href="#bugs">How to report problems</a></li> + <li><a href="#building">Building Steeldump</a></li> + <li><a href="#extending">Extending Steeldump</a></li> + </ul> + </li> + <li> + <a href="http://common-lisp.net/cgi-bin/mailman/listinfo/steeldump-devel"> + steeldump-devel(a)common-lisp.net + </a> + </li> + <li> + <a href="http://common-lisp.net/websvn/listing.php?repname=steeldump&path=%2F&sc=0"> + Browse SVN + </a> + </li> + </ul> + </div> + <div class="sidebar-title"> + steeldumped applications + </div> + <div class="sidebar-main"> + <ul> + <li><a href="http://common-lisp.net/project/beirc">beirc</a></li> + <li><a href="http://common-lisp.net/project/climacs">climacs</a></li> + <li><a href="http://common-lisp.net/project/gsharp">gsharp</a></li> + </ul> + </div> + <div class="sidebar-title"> + steeldumped libraries + </div> + <div class="sidebar-main"> + <ul> + <li><a href="http://weitz.de/cl-fad/">cl-fad</a></li> + <li><a href="http://common-lisp.net/project/cl-irc">cl-irc</a></li> + <li><a href="http://weitz.de/cl-ppcre/">cl-ppcre</a></li> + <li> + <a href="http://common-lisp.net/project/climacs">esa</a> + (<a href="http://www.cliki.net/esa">about</a>) + </li> + <li><a href="http://www.cliki.net/CLX">clx</a></li> + <li><a href="http://weitz.de/flexi-streams/">flexi-streams</a></li> + <li><a href="http://common-lisp.net/project/flexichain">flexichain</a></li> + <li><a href="http://common-lisp.net/project/mcclim">McCLIM</a></li> + <li><a href="http://www.cliki.net/spatial-trees">spatial-trees</a></li> + <li><a href="http://www.cliki.net/split-sequence">split-sequence</a></li> + <li>tab-layout</li> + <li><a href="http://common-lisp.net/project/cl-plus-ssl#trivial-gray-streams">trivial-gray-streams</a></li> + <li><a href="http://www.cliki.net/trivial-sockets">trivial-sockets</a></li> + </ul> + </div> + </div> + + <h1>Steeldump<sub style="font-weight: normal; font-size: 10pt; color: #009c00">BETA</sub></h1> + + <p> + Steeldump is an unofficial APT repository for applications written + in Common Lisp. + </p> + + <ul> + <li> + Steeldump provides <i>binary</i> packages based on + <a href="http://www.sbcl.org">SBCL</a>. + </li> + <li> + It uses sb-heapdump as the binary format. + </li> + <li> + The focus is on end-user applications, with libraries being pulled in + only as necessary. + </li> + <li> + Currently only for x86 (built by David Lichteblau on Debian testing). + </li> + </ul> + + <p> + All packages included are assumed to be Free Software under + various different licenses. <i>No warranty whatsoever can be + provided for Steeldump.</i> "Now fear, comprehensively." + </p> + + <h3>News</h3> + <b>2006-05-21</b> + <p> + First public release. Please test gently. Based on SBCL 0.9.12. + </p> + <p> + Changes since the very first #lisp preview release: + </p> + <ul> + <li> + Added: beirc, cl-irc, trivial-sockets, flexi-streams, + trivial-gray-streams, tab-layout, cl-fad, cl-ppcre. + </li> + <li> + Fixed: climacs command table issues. + </li> + <li> + Changed: ASDF integration. No more startup messages. + </li> + </ul> + + <h3> + Installation + <a name="installation"></a> + </h3> + <p> + Add the following line to <tt>/etc/apt/sources.list</tt>, then run + <tt>aptitude update</tt>. + </p> + <pre style="width: 60%">deb http://common-lisp.net/project/steeldump unstable main</pre> + + <p> + Packages are all named <tt>steeldump-</tt><i>foo</i>. E.g., to + install climacs, type <tt>aptitude install + steeldump-climacs</tt>. All packages install exclusively to + <tt>/opt/steeldump</tt> and do not interact with the "normal" + Lisp packages included in Debian at all. + </p> + <p> + There are no source code packages, but full source code is + included in each binary package. (Except for SBCL itself, which + is packaged as <tt>steeldump-sbcl</tt> with source code only + for the contribs, as usual.) + </p> + + <h3> + Usage + <a name="usage"></a> + </h3> + <ul> + <li> + Binaries (for the applications) can be found in + <tt>/opt/steeldump/bin</tt>. + </li> + <li> + SBCL can be started manually using <tt>/opt/steeldump/bin/sbcl</tt>. + <br/> + (Make sure that <tt>$SBCL_HOME</tt> 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.) + </li> + <li> + <tt>bin/sbcl</tt> loads user init files (~/.sbclrc). The + application scripts do not. + </li> + <li> + To load heapdumped systems at the Lisp REPL manually, use + <tt>(require :foo)</tt>. + </li> + <li> + It is possible to use ASDF's <tt>load-op</tt> instead, although + that just ends up calling <tt>require</tt> through a trampoline + system. Once the heap file has been loaded, however, a real + asdf system object takes charge. + </li> + <li> + 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. + </li> + </ul> + + <h3> + How to report problems + <a name="bugs"></a> + </h3> + <p> + 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. + </p> + <p> + If you believe steeldump is to blame, please send bug reports to + <a + href="mailto:steeldump-devel@common-lisp.net">steeldump-devel(a)common-lisp.net</a> + 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. + </p> + <p> + If, however, the bug is also present is the upstream source code, + please send your report directly to the upstream project. Thanks. + </p> + + <h3> + Building Steeldump + <a name="building"></a> + </h3> + <p> + (You can skip this section if you just want to use steeldump + packages normally. See above for installation instructions.) + </p> + <p> + To help debugging or developing Steeldump, the following steps + should be enough to build your own steeldump packages: + </p> + <ul> + <li> + Set up a chroot environment or virtual machine to compile + steeldump in. + <br/> + <br/> + If you really do not want to do this, keep this in mind: + Steeldump <i>must</i> be compiled in the exact same location + where it is going to be installed into, + <tt>/opt/steeldump</tt>. So you cannot run the steeldump + scripts in a filesystem where steeldump packages are already + installed. + <br/> + <br/> + Although it does not address safety issues, you can obviously + build a mock-up chroot very easily using <tt>mount -o bind</tt>, + so this should not be too much of an issue. + </li> + <li> + Create a new directory <tt>/opt/steeldump</tt>. In the build + environment, this directory should be owned by a non-root user. + (The build scripts will only run <tt>sudo</tt> briefly for each + package to fix file ownership before packaging the files up. + Building should be done normally under your non-root account.) + </li> + <li> + Check out the steeldump scripts from Subversion: + <pre>$ cd /opt/steeldump +$ svn co svn://common-lisp.net/project/steeldump/svn/trunk/scripts</pre> + </li> + <li> + Run the first script: + <pre>/opt/steeldump$ ./scripts/init</pre> + -- 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. + </li> + <li> + The first package you need to download and build is SBCL: + <pre>$ ./scripts/fetch-sbcl +$ ./scripts/build-sbcl +$ ./scripts/makedeb-sbcl</pre> + </li> + </ul> + <p> + Congratulations: If that worked, you have your first .deb package in + <tt>/opt/steeldump/pool</tt>. + </p> + <ul> + <li> + Now you can build the actual steeldumped applications using the + same steps: + <pre>$ ./scripts/fetch-all +$ ./scripts/build-all +$ ./scripts/makedeb-all</pre> + </li> + </ul> + <p> + And that's it. After makedeb-all, you can find all packages in + the <tt>pool</tt> directory. + </p> + <p> + While debugging, however, you will probably want to build + individual packages instead of all in one go: + </p> + <ul> + <li> + For every system, there is a separate <tt>fetch-</tt><i>foo</i> + script. These fetch-scripts do <i>not</i> track dependencies + for you. When not using <tt>fetch-all</tt>, make sure to + download everything you need before trying to build. + </li> + <li> + The <tt>build-</tt><i>foo</i> scripts can be invoked in an + arbitrary order. For example, building climacs will + automatically compile mcclim if it had not been compiled + yet. <i>However</i>, it does not actually create the dumpfile + for mcclim, you will still have to call <tt>build-mcclim</tt> + eventually before you can make its .deb file. + </li> + <li> + Finally, for <tt>makedeb-all</tt> note that it has one advantage + over the individual <tt>makedeb-</tt><i>foo</i> scripts: Before + calling out to the others, <tt>makedeb-all</tt> relocates the + heap files to non-overlapping locations, speeding up loading of + the heap files a little. + </li> + </ul> + <p> + If you got this far and have working packages in + <tt>/opt/steeldump/pool</tt>, send me a postcard. + </p> + + <h3> + Extending Steeldump + <a name="extending"></a> + </h3> + <p> + (You can skip this section if you just want to use steeldump + packages normally. See above for installation instructions.) + </p> + <p> + To add a new package called "blubba", create these files: + </p> + <ul> + <li> + <tt>/opt/steeldump/scripts/fetch-blubba</tt><br/> + This script must put the source code into + <tt>/opt/steeldump/src/blubba</tt>. Remove version numbers from + the directory name, if any.<br/> + Look at the other fetch scripts for ideas. Usually it is enough + to call one of the helper scripts, <tt>aux/fetch-url</tt>, + <tt>aux/fetch-cvs</tt>, or <tt>aux/fetch-svn</tt>. If you have + to patch the source code, this script is the right place to do + that. + </li> + <li> + <tt>/opt/steeldump/scripts/build-blubba</tt><br/> + Usually this script is trivial and just + calls <tt>build-system</tt>. Copy + over <tt>/opt/steeldump/scripts/build-SAMPLE</tt> and change the + system name from "SAMPLESSYTEMNAME" to "blubba". This script + is the right place to call "make" if the system includes C code. + </li> + <li> + <tt>/opt/steeldump/scripts/lisp/build-blubba.lisp</tt><br/> + This Lisp script is less trivial. Starting from the sample file + <tt>/opt/steeldump/scripts/lisp/build-SAMPLE.lisp</tt>, change + the system name from "SAMPLE" to "blubba", but review the + heap dumping logic carefully. The heap dumper needs to be told + about: + <ul> + <li> + The packages that are to be dumped (look out for multiple + defpackage forms). This is the first argument + to <tt>dump-system</tt>. + </li> + <li> + The ASDF systems involved. If the .asd file contains + multiple system definitions, all of them must be listed + manually in the build script. (The <tt>:system</tt> + argument.) + </li> + <li> + The name of the package the .asd files defines and uses. + (The <tt>:system-package</tt> argument.) + </li> + </ul> + You now have a first draft of the dumping script. Beware that + <em>dumping</em> 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 <em>other</em> packages, slots of objects the heap dumper + cannot know about, etc. + <ul> + <li> + Refer to sb-heapdump documentation on the precise logic used + by the dumper. + </li> + <li> + 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. + </li> + <li> + 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. + </li> + </ul> + </li> + <li> + <tt>/opt/steeldump/scripts/descriptions/blubba</tt><br/> + This file ends up as the <tt>Description:</tt> header in the + Debian package's <tt>control</tt> file. + Again there is a skeleton file: + <tt>/opt/steeldump/scripts/descriptions/SAMPLE</tt>. + </li> + <li> + <tt>/opt/steeldump/scripts/makedeb-blubba</tt><br/> + This scripts collect all files to be installed and creates the + .deb archive. Starting + with <tt>/opt/steeldump/scripts/makedeb-SAMPLE</tt>, + 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. + </li> + </ul> + </body> +</html> 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; +}

1 0

[steeldump-cvs] r3 - in trunk: sb-heapdump sb-heapdump/CVS scripts
by dlichteblau＠common-lisp.net 21 May '06

21 May '06

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

1 0

[steeldump-cvs] r2 - in trunk/scripts: . aux data descriptions lisp patches
by dlichteblau＠common-lisp.net 21 May '06

21 May '06

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 +Package: $package +Version: $version +Architecture: i386 +Depends: $depends +Maintainer: David Lichteblau <dlichteblau(a)common-lisp.net> +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 <<eof +(asdf:defsystem :$system :class sb-heapdump::module-trampoline) +eof Added: trunk/scripts/build-SAMPLE ============================================================================== --- (empty file) +++ trunk/scripts/build-SAMPLE Sun May 21 14:28:03 2006 @@ -0,0 +1,3 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/build-system SAMPLESYSTEMNAME Added: trunk/scripts/build-all ============================================================================== --- (empty file) +++ trunk/scripts/build-all Sun May 21 14:28:03 2006 @@ -0,0 +1,19 @@ +#!/bin/sh -e + +if test -e /opt/steeldump/lib/sbcl/sbcl.core; then + echo "SBCL already installed, skipping" +else + /opt/steeldump/scripts/build-sbcl +fi + +for system in climacs gsharp clx esa flexichain mcclim spatial-trees \ + split-sequence cl-ppcre cl-fad tab-layout trivial-gray-streams \ + flexi-streams trivial-sockets cl-irc beirc +do + f=/opt/steeldump/lib/sbcl/${system}.heap + if test -e $f; then + echo "$f already present, skipping" + else + /opt/steeldump/scripts/build-$system + fi +done Added: trunk/scripts/build-beirc ============================================================================== --- (empty file) +++ trunk/scripts/build-beirc Sun May 21 14:28:03 2006 @@ -0,0 +1,3 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/build-system beirc Added: trunk/scripts/build-cl-fad ============================================================================== --- (empty file) +++ trunk/scripts/build-cl-fad Sun May 21 14:28:03 2006 @@ -0,0 +1,3 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/build-system cl-fad Added: trunk/scripts/build-cl-irc ============================================================================== --- (empty file) +++ trunk/scripts/build-cl-irc Sun May 21 14:28:03 2006 @@ -0,0 +1,3 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/build-system cl-irc Added: trunk/scripts/build-cl-ppcre ============================================================================== --- (empty file) +++ trunk/scripts/build-cl-ppcre Sun May 21 14:28:03 2006 @@ -0,0 +1,3 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/build-system cl-ppcre Added: trunk/scripts/build-climacs ============================================================================== --- (empty file) +++ trunk/scripts/build-climacs Sun May 21 14:28:03 2006 @@ -0,0 +1,3 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/build-system climacs Added: trunk/scripts/build-clx ============================================================================== --- (empty file) +++ trunk/scripts/build-clx Sun May 21 14:28:03 2006 @@ -0,0 +1,3 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/build-system clx Added: trunk/scripts/build-esa ============================================================================== --- (empty file) +++ trunk/scripts/build-esa Sun May 21 14:28:03 2006 @@ -0,0 +1,3 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/build-system esa Added: trunk/scripts/build-flexi-streams ============================================================================== --- (empty file) +++ trunk/scripts/build-flexi-streams Sun May 21 14:28:03 2006 @@ -0,0 +1,3 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/build-system flexi-streams Added: trunk/scripts/build-flexichain ============================================================================== --- (empty file) +++ trunk/scripts/build-flexichain Sun May 21 14:28:03 2006 @@ -0,0 +1,3 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/build-system flexichain Added: trunk/scripts/build-gsharp ============================================================================== --- (empty file) +++ trunk/scripts/build-gsharp Sun May 21 14:28:03 2006 @@ -0,0 +1,4 @@ +#!/bin/sh -e +set -x +(set -e; cd /opt/steeldump/src/gsharp/Fonts && make) +/opt/steeldump/scripts/aux/build-system gsharp Added: trunk/scripts/build-mcclim ============================================================================== --- (empty file) +++ trunk/scripts/build-mcclim Sun May 21 14:28:03 2006 @@ -0,0 +1,3 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/build-system mcclim Added: trunk/scripts/build-sbcl ============================================================================== --- (empty file) +++ trunk/scripts/build-sbcl Sun May 21 14:28:03 2006 @@ -0,0 +1,43 @@ +#!/bin/sh -e +set -x +unset SBCL_HOME + +cd /opt/steeldump/src/sbcl + +cat >customize-target-features.lisp <<eof +(lambda (x) + (pushnew :sb-thread x) + (pushnew :sb-futex x) + (pushnew :sb-ldb x) + x) +eof + +cat >>src/runtime/runtime.h <<eof +#define SBCL_HOME "/opt/steeldump/lib/sbcl" +eof + +cat >>contrib/asdf/asdf.lisp <<eof +(defmethod asdf:perform :around ((o asdf:load-op) (c asdf:cl-source-file)) + (handler-case + (call-next-method o c) + (sb-ext:invalid-fasl () + (asdf:perform (make-instance 'asdf:compile-op) c) + (call-next-method)))) +eof + +sh clean.sh +sh make.sh 'lisp -noinit' + +export INSTALL_ROOT=/opt/steeldump +mkdir -p $INSTALL_ROOT +sh install.sh + +cd $INSTALL_ROOT + +export SBCL_HOME="/opt/steeldump/lib/sbcl" +mv lib/sbcl/sbcl.core vanilla.core +./bin/sbcl \ + --core vanilla.core \ + --userinit /dev/null \ + --sysinit /dev/null \ + --load "/opt/steeldump/scripts/lisp/build-sbcl.lisp" Added: trunk/scripts/build-spatial-trees ============================================================================== --- (empty file) +++ trunk/scripts/build-spatial-trees Sun May 21 14:28:03 2006 @@ -0,0 +1,3 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/build-system spatial-trees Added: trunk/scripts/build-split-sequence ============================================================================== --- (empty file) +++ trunk/scripts/build-split-sequence Sun May 21 14:28:03 2006 @@ -0,0 +1,3 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/build-system split-sequence Added: trunk/scripts/build-tab-layout ============================================================================== --- (empty file) +++ trunk/scripts/build-tab-layout Sun May 21 14:28:03 2006 @@ -0,0 +1,3 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/build-system tab-layout Added: trunk/scripts/build-trivial-gray-streams ============================================================================== --- (empty file) +++ trunk/scripts/build-trivial-gray-streams Sun May 21 14:28:03 2006 @@ -0,0 +1,3 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/build-system trivial-gray-streams Added: trunk/scripts/build-trivial-sockets ============================================================================== --- (empty file) +++ trunk/scripts/build-trivial-sockets Sun May 21 14:28:03 2006 @@ -0,0 +1,3 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/build-system trivial-sockets Added: trunk/scripts/data/beirc ============================================================================== --- (empty file) +++ trunk/scripts/data/beirc Sun May 21 14:28:03 2006 @@ -0,0 +1,9 @@ +#!/bin/sh +unset SBCL_HOME +exec /opt/steeldump/bin/sbcl \ + --noinform \ + --userinit /dev/null \ + --disable-debugger \ + --eval '(setf sb-heapdump:*dumpload-verbose* nil)' \ + --eval '(require :beirc)' \ + --eval '(progn (beirc:beirc :new-process nil) (sb-ext:quit))' Added: trunk/scripts/data/clim-listener ============================================================================== --- (empty file) +++ trunk/scripts/data/clim-listener Sun May 21 14:28:03 2006 @@ -0,0 +1,9 @@ +#!/bin/sh +unset SBCL_HOME +exec /opt/steeldump/bin/sbcl \ + --noinform \ + --userinit /dev/null \ + --disable-debugger \ + --eval '(setf sb-heapdump:*dumpload-verbose* nil)' \ + --eval '(require :mcclim)' \ + --eval '(progn (clim-listener:run-listener) (sb-ext:quit))' Added: trunk/scripts/data/climacs ============================================================================== --- (empty file) +++ trunk/scripts/data/climacs Sun May 21 14:28:03 2006 @@ -0,0 +1,9 @@ +#!/bin/sh +unset SBCL_HOME +exec /opt/steeldump/bin/sbcl \ + --noinform \ + --userinit /dev/null \ + --disable-debugger \ + --eval '(setf sb-heapdump:*dumpload-verbose* nil)' \ + --eval '(require :climacs)' \ + --eval '(progn (climacs-gui:climacs) (sb-ext:quit))' Added: trunk/scripts/data/gsharp ============================================================================== --- (empty file) +++ trunk/scripts/data/gsharp Sun May 21 14:28:03 2006 @@ -0,0 +1,9 @@ +#!/bin/sh +unset SBCL_HOME +exec /opt/steeldump/bin/sbcl \ + --noinform \ + --userinit /dev/null \ + --disable-debugger \ + --eval '(setf sb-heapdump:*dumpload-verbose* nil)' \ + --eval '(require :gsharp)' \ + --eval '(progn (gsharp:gsharp) (sb-ext:quit))' Added: trunk/scripts/descriptions/SAMPLE ============================================================================== --- (empty file) +++ trunk/scripts/descriptions/SAMPLE Sun May 21 14:28:03 2006 @@ -0,0 +1,4 @@ +Description: SHORTDESCRIPTIONGOESHERE (steeldump package) + LONGDESCRIPTIONGOESHERE + . + This is a non-Debian binary package from the steeldump repository. Added: trunk/scripts/descriptions/beirc ============================================================================== --- (empty file) +++ trunk/scripts/descriptions/beirc Sun May 21 14:28:03 2006 @@ -0,0 +1,6 @@ +Description: A CLIM-based IRC client (steeldump package) + beirc is a graphical Internet Relay Chat client using the clim (or + mcclim) graphical library and built on top of cl-irc. beirc is the + creation of Gilbert Baumann. + . + This is a non-Debian binary package from the steeldump repository. Added: trunk/scripts/descriptions/cl-fad ============================================================================== --- (empty file) +++ trunk/scripts/descriptions/cl-fad Sun May 21 14:28:03 2006 @@ -0,0 +1,11 @@ +Description: portable pathname library for Common Lisp (steeldump package) + CL-FAD is a filename and directory abstraction library for several + Common Lisp implementations. It provides common file operations + implementation-independently. + . + Parts of this library consist of code from the book "Practical Common + Lisp" by Peter Seibel. + . + Homepage: http://weitz.de/cl-fad/ + . + This is a non-Debian binary package from the steeldump repository. Added: trunk/scripts/descriptions/cl-irc ============================================================================== --- (empty file) +++ trunk/scripts/descriptions/cl-irc Sun May 21 14:28:03 2006 @@ -0,0 +1,6 @@ +Description: Common Lisp Internet Relay Chat Library (steeldump package) + cl-irc provides a library for Common Lisp programs to interact with + IRC servers. This library has been most tested with SBCL. + Several example programs are provided. + . + This is a non-Debian binary package from the steeldump repository. Added: trunk/scripts/descriptions/cl-ppcre ============================================================================== --- (empty file) +++ trunk/scripts/descriptions/cl-ppcre Sun May 21 14:28:03 2006 @@ -0,0 +1,9 @@ +Description: Portable Regular Expr. Library for Common Lisp (steeldump package) + CL-PPCRE is a portable regular expression library for Common Lisp + which has the following features: + . + * It is compatible with Perl. + * It is fast. + * It is portable. + . + This is a non-Debian binary package from the steeldump repository. Added: trunk/scripts/descriptions/climacs ============================================================================== --- (empty file) +++ trunk/scripts/descriptions/climacs Sun May 21 14:28:03 2006 @@ -0,0 +1,7 @@ +Description: A modern Common Lisp implementation of Emacs (steeldump package) + Climacs, a project to create a Common Lisp version of Emacs. In fact, + this project is merely meant to replace all other Common Lisp Emacsen, + such as Goatee (the editor of McCLIM) and Portable Hemlock, both of + which have non-existent or outdated buffer protocols. + . + This is a non-Debian binary package from the steeldump repository. Added: trunk/scripts/descriptions/clx ============================================================================== --- (empty file) +++ trunk/scripts/descriptions/clx Sun May 21 14:28:03 2006 @@ -0,0 +1,5 @@ +Description: An X11 Common Lisp client library for SBCL (steeldump package) + CLX is a low-level X11 client library for Common Lisp. CLX is to Lisp what + Xlib is to C. + . + This is a non-Debian binary package from the steeldump repository. Added: trunk/scripts/descriptions/esa ============================================================================== --- (empty file) +++ trunk/scripts/descriptions/esa Sun May 21 14:28:03 2006 @@ -0,0 +1,5 @@ +Description: CLIM Emacs-Style Application framework (steeldump package) + ESA is a layer atop CLIM functionality to provide an Emacs-Style + Application framework. + . + This is a non-Debian binary package from the steeldump repository. Added: trunk/scripts/descriptions/flexi-streams ============================================================================== --- (empty file) +++ trunk/scripts/descriptions/flexi-streams Sun May 21 14:28:03 2006 @@ -0,0 +1,8 @@ +Description: Flexible bivalent streams for Common Lisp (steeldump package) + FLEXI-STREAMS implements "virtual" bivalent streams that can be layered + atop real binary or bivalent streams and that can be used to read and + write character data in various single- or multi-octet encodings which + can be changed on the fly. It also supplies in-memory binary streams + which are similar to string streams. + . + This is a non-Debian binary package from the steeldump repository. Added: trunk/scripts/descriptions/flexichain ============================================================================== --- (empty file) +++ trunk/scripts/descriptions/flexichain Sun May 21 14:28:03 2006 @@ -0,0 +1,8 @@ +Description: A library for editable sequences (steeldump package) + Flexichain is an API for editable sequences. Its primary use is in + end-user applications that edit sequences of objects such as text + editors (characters), word processors (characters, paragraphs, + sections, etc), score editors (notes, clusters, measures, etc), though + it can also be used as a stack and a double-ended queue. + . + This is a non-Debian binary package from the steeldump repository. Added: trunk/scripts/descriptions/gsharp ============================================================================== --- (empty file) +++ trunk/scripts/descriptions/gsharp Sun May 21 14:28:03 2006 @@ -0,0 +1,4 @@ +Description: An interactive, extensible editor for musical scores (steeldump package) + Gsharp is an interactive, extensible editor for musical scores. + . + This is a non-Debian binary package from the steeldump repository. Added: trunk/scripts/descriptions/mcclim ============================================================================== --- (empty file) +++ trunk/scripts/descriptions/mcclim Sun May 21 14:28:03 2006 @@ -0,0 +1,5 @@ +Description: Open source Common Lisp Interface Manager (steeldump package) + McCLIM is an open source implementation of the Common Lisp Interface Manager + specification. + . + This is a non-Debian binary package from the steeldump repository. Added: trunk/scripts/descriptions/sbcl ============================================================================== --- (empty file) +++ trunk/scripts/descriptions/sbcl Sun May 21 14:28:03 2006 @@ -0,0 +1,13 @@ +Description: A Common Lisp compiler and development system (for steeldump) + SBCL is a development environment for the ANSI Common Lisp language. + It provides a native-code compiler and an integrated debugger, as well + as all the features in the ANSI specification. + . + This is a non-Debian package from the steeldump repository. Changes + compared to upstream: + - threads and ldb enabled + - installation location hardwired to /opt/steeldump + - sb-heapdump contrib added + - asdf, sb-bsd-sockets, sb-heapdump, sb-posix dumped into core + - asdf patched to recompile invalid fasls automatically + - asdf patched so that site-systems overrides .sbcl/systems Added: trunk/scripts/descriptions/spatial-trees ============================================================================== --- (empty file) +++ trunk/scripts/descriptions/spatial-trees Sun May 21 14:28:03 2006 @@ -0,0 +1,5 @@ +Description: Library for spatially-extended data (steeldump package) + spatial-trees is a Library which provides access to dynamic index structures + for spatially-extended data, all exposed through a uniform CLOS interface. + . + This is a non-Debian binary package from the steeldump repository. Added: trunk/scripts/descriptions/split-sequence ============================================================================== --- (empty file) +++ trunk/scripts/descriptions/split-sequence Sun May 21 14:28:03 2006 @@ -0,0 +1,5 @@ +Description: A common lisp utility library (steeldump package) + Splits a sequence into a list of subsequences delimited by objects + satisfying a test. + . + This is a non-Debian binary package from the steeldump repository. Added: trunk/scripts/descriptions/tab-layout ============================================================================== --- (empty file) +++ trunk/scripts/descriptions/tab-layout Sun May 21 14:28:03 2006 @@ -0,0 +1,5 @@ +Description: CLIM extensions based on stack-layout (steeldump package) + This library defines CLIM extensions tab-layout, radio-layout, and + stack-layout. + . + This is a non-Debian binary package from the steeldump repository. Added: trunk/scripts/descriptions/trivial-gray-streams ============================================================================== --- (empty file) +++ trunk/scripts/descriptions/trivial-gray-streams Sun May 21 14:28:03 2006 @@ -0,0 +1,6 @@ +Description: gray streams portability shim (steeldump package) + This trivial library provides an implementation's gray stream support + under a portable package name and papers over differences between + read-/write-sequence support, which varies widely. + . + This is a non-Debian binary package from the steeldump repository. Added: trunk/scripts/descriptions/trivial-sockets ============================================================================== --- (empty file) +++ trunk/scripts/descriptions/trivial-sockets Sun May 21 14:28:03 2006 @@ -0,0 +1,14 @@ +Description: a Common Lisp socket interface (steeldump package) + trivial-sockets is a portable socket interface that allows Common + Lisp programs to open connected (client) stream sockets to network + service (for example HTTP, FTP or SMTP servers) and communicate with + them. It's intended mostly for "scripting" and interactive use. + . + Note that in the interests of simplicity and ease of porting, the + functionality available through TRIVIAL-SOCKETS has been deliberately + restricted. + . + The documentation is provided in Texinfo and HTML formats. You can + generate a PDF output using the suggested texinfo package. + . + This is a non-Debian binary package from the steeldump repository. Added: trunk/scripts/fetch-all ============================================================================== --- (empty file) +++ trunk/scripts/fetch-all Sun May 21 14:28:03 2006 @@ -0,0 +1,11 @@ +#!/bin/sh -e +for system in sbcl clx esa flexichain mcclim spatial-trees split-sequence \ + climacs gsharp cl-ppcre cl-fad tab-layout trivial-gray-streams \ + flexi-streams trivial-sockets cl-irc beirc +do + if test -e /opt/steeldump/src/$system; then + echo "$system already present, skipping" + else + /opt/steeldump/scripts/fetch-$system + fi +done Added: trunk/scripts/fetch-beirc ============================================================================== --- (empty file) +++ trunk/scripts/fetch-beirc Sun May 21 14:28:03 2006 @@ -0,0 +1,5 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/fetch-cvs \ + :pserver:anonymous:anonymous@common-lisp.net:/project/beirc/cvsroot \ + beirc Added: trunk/scripts/fetch-cl-fad ============================================================================== --- (empty file) +++ trunk/scripts/fetch-cl-fad Sun May 21 14:28:03 2006 @@ -0,0 +1,8 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/fetch-url \ + z \ + http://weitz.de/files/ \ + cl-fad.tar.gz \ + cl-fad-0.5.0 \ + cl-fad Added: trunk/scripts/fetch-cl-irc ============================================================================== --- (empty file) +++ trunk/scripts/fetch-cl-irc Sun May 21 14:28:03 2006 @@ -0,0 +1,5 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/fetch-svn \ + svn://common-lisp.net/project/cl-irc/svn/trunk \ + cl-irc Added: trunk/scripts/fetch-cl-ppcre ============================================================================== --- (empty file) +++ trunk/scripts/fetch-cl-ppcre Sun May 21 14:28:03 2006 @@ -0,0 +1,8 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/fetch-url \ + z \ + http://weitz.de/files/ \ + cl-ppcre.tar.gz \ + cl-ppcre-1.2.13 \ + cl-ppcre Added: trunk/scripts/fetch-climacs ============================================================================== --- (empty file) +++ trunk/scripts/fetch-climacs Sun May 21 14:28:03 2006 @@ -0,0 +1,8 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/fetch-cvs \ + :pserver:anonymous:anonymous@common-lisp.net:/project/climacs/cvsroot \ + climacs \ + "-r HEAD" +cd /opt/steeldump/src/climacs +patch -p0 </opt/steeldump/scripts/patches/climacs.diff Added: trunk/scripts/fetch-clx ============================================================================== --- (empty file) +++ trunk/scripts/fetch-clx Sun May 21 14:28:03 2006 @@ -0,0 +1,8 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/fetch-url \ + z \ + http://ftp.linux.org.uk/pub/lisp/sbcl/ \ + clx_0.7.3.tar.gz \ + clx_0.7.3 \ + clx Added: trunk/scripts/fetch-esa ============================================================================== --- (empty file) +++ trunk/scripts/fetch-esa Sun May 21 14:28:03 2006 @@ -0,0 +1,6 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/fetch-cvs \ + :pserver:anonymous:anonymous@common-lisp.net:/project/climacs/cvsroot \ + esa \ + "-r HEAD" Added: trunk/scripts/fetch-flexi-streams ============================================================================== --- (empty file) +++ trunk/scripts/fetch-flexi-streams Sun May 21 14:28:03 2006 @@ -0,0 +1,8 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/fetch-url \ + z \ + http://weitz.de/files/ \ + flexi-streams.tar.gz \ + flexi-streams-0.5.4 \ + flexi-streams Added: trunk/scripts/fetch-flexichain ============================================================================== --- (empty file) +++ trunk/scripts/fetch-flexichain Sun May 21 14:28:03 2006 @@ -0,0 +1,6 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/fetch-cvs \ + :pserver:anonymous:anonymous@common-lisp.net:/project/flexichain/cvsroot \ + flexichain \ + "-r HEAD" Added: trunk/scripts/fetch-gsharp ============================================================================== --- (empty file) +++ trunk/scripts/fetch-gsharp Sun May 21 14:28:03 2006 @@ -0,0 +1,6 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/fetch-cvs \ + :pserver:anonymous:anonymous@common-lisp.net:/project/gsharp/cvsroot \ + gsharp \ + "-r HEAD" Added: trunk/scripts/fetch-mcclim ============================================================================== --- (empty file) +++ trunk/scripts/fetch-mcclim Sun May 21 14:28:03 2006 @@ -0,0 +1,6 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/fetch-cvs \ + :pserver:anonymous:anonymous@common-lisp.net:/project/mcclim/cvsroot \ + mcclim \ + "-r HEAD" Added: trunk/scripts/fetch-sbcl ============================================================================== --- (empty file) +++ trunk/scripts/fetch-sbcl Sun May 21 14:28:03 2006 @@ -0,0 +1,17 @@ +#!/bin/sh -e +set -x +#mirror=http://osdn.dl.sourceforge.net/sourceforge +mirror=http://belnet.dl.sourceforge.net/sourceforge + +cd /opt/steeldump +./scripts/aux/fetch-url \ + j \ + $mirror/sbcl/ \ + sbcl-0.9.12-source.tar.bz2 \ + sbcl-0.9.12 \ + sbcl +./scripts/aux/fetch-cvs \ + /home/david/cvsroot \ + sb-heapdump \ + "-r HEAD" +cp -r src/sb-heapdump src/sbcl/contrib Added: trunk/scripts/fetch-spatial-trees ============================================================================== --- (empty file) +++ trunk/scripts/fetch-spatial-trees Sun May 21 14:28:03 2006 @@ -0,0 +1,8 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/fetch-url \ + z \ + http://ftp.linux.org.uk/pub/lisp/cclan/ \ + spatial-trees-0.2.tar.gz \ + spatial-trees-0.2 \ + spatial-trees Added: trunk/scripts/fetch-split-sequence ============================================================================== --- (empty file) +++ trunk/scripts/fetch-split-sequence Sun May 21 14:28:03 2006 @@ -0,0 +1,7 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/fetch-url \ + z \ + http://ftp.linux.org.uk/pub/lisp/cclan/ \ + split-sequence_20011114.1.tar.gz \ + split-sequence Added: trunk/scripts/fetch-tab-layout ============================================================================== --- (empty file) +++ trunk/scripts/fetch-tab-layout Sun May 21 14:28:03 2006 @@ -0,0 +1,7 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/fetch-url \ + j \ + http://bl0rg.net/~mgr/flux/ \ + tab-layout_2005-09-19_02-52+0200.tar.bz2 \ + tab-layout Added: trunk/scripts/fetch-trivial-gray-streams ============================================================================== --- (empty file) +++ trunk/scripts/fetch-trivial-gray-streams Sun May 21 14:28:03 2006 @@ -0,0 +1,5 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/fetch-cvs \ + :pserver:anonymous:anonymous@common-lisp.net:/project/cl-plus-ssl/cvsroot \ + trivial-gray-streams Added: trunk/scripts/fetch-trivial-sockets ============================================================================== --- (empty file) +++ trunk/scripts/fetch-trivial-sockets Sun May 21 14:28:03 2006 @@ -0,0 +1,8 @@ +#!/bin/sh -e +set -x +/opt/steeldump/scripts/aux/fetch-url \ + z \ + http://www-jcsu.jesus.cam.ac.uk/ftp/pub/cclan/ \ + trivial-sockets_0.3.tar.gz \ + trivial-sockets_0.3 \ + trivial-sockets Added: trunk/scripts/generate-dists ============================================================================== --- (empty file) +++ trunk/scripts/generate-dists Sun May 21 14:28:03 2006 @@ -0,0 +1,18 @@ +#!/bin/sh -e +set +x + +cd /opt/steeldump +mkdir -p dists/unstable/main/binary-i386 + +ls -1 pool | sed 's/_.*$/ priority section/' | uniq > override + +dpkg-scanpackages pool override | gzip >dists/unstable/main/binary-i386/Packages.gz + +cat >dists/unstable/main/Release <<eof +Archive: unstable +Version: 3.0 +Component: main +Origin: Local +Label: Local +Architecture: i386 +eof Added: trunk/scripts/init ============================================================================== --- (empty file) +++ trunk/scripts/init Sun May 21 14:28:03 2006 @@ -0,0 +1,19 @@ +#!/bin/sh -e +rc=0 + +mkdir -p /opt/steeldump/src +mkdir -p /opt/steeldump/pool + +if ! which lisp >/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)) + +

1 0