Commit | Line | Data |
---|---|---|
e29834b8 MW |
1 | #! /bin/sh -e |
2 | ### | |
3 | ### Dump Lisp images for faster script execution | |
4 | ### | |
5 | ### (c) 2020 Mark Wooding | |
6 | ### | |
7 | ||
8 | ###----- Licensing notice --------------------------------------------------- | |
9 | ### | |
10 | ### This file is part of Runlisp, a tool for invoking Common Lisp scripts. | |
11 | ### | |
12 | ### Runlisp is free software: you can redistribute it and/or modify it | |
13 | ### under the terms of the GNU General Public License as published by the | |
14 | ### Free Software Foundation; either version 3 of the License, or (at your | |
15 | ### option) any later version. | |
16 | ### | |
17 | ### Runlisp is distributed in the hope that it will be useful, but WITHOUT | |
18 | ### ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
19 | ### FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
20 | ### for more details. | |
21 | ### | |
22 | ### You should have received a copy of the GNU General Public License | |
23 | ### along with Runlisp. If not, see <https://www.gnu.org/licenses/>. | |
24 | ||
25 | ###-------------------------------------------------------------------------- | |
26 | ### Build-time configuration. | |
27 | ||
28 | VERSION=@VERSION@ | |
29 | imagedir=@imagedir@ | |
30 | eclopt=@ECLOPT@ | |
31 | ||
32 | ###-------------------------------------------------------------------------- | |
33 | ### Random utilities. | |
34 | ||
35 | prog=${0##*/} | |
36 | ||
37 | ## Report a fatal error. | |
38 | lose () { echo >&2 "$prog: $*"; exit 2; } | |
39 | ||
40 | ## Quote a string so that Lisp will understand it. | |
41 | lisp_quote () { printf "%s\n" "$1" | sed 's/[\\"]/\\&/g'; } | |
42 | ||
43 | ## Mention that we're running a program. | |
44 | run () { echo "$*"; $lbuf "$@"; } | |
45 | ||
46 | ## Figure out whether we can force line-buffering. | |
47 | if stdbuf --version >/dev/null 2>&1; then lbuf="stdbuf -oL --" | |
48 | else lbuf=""; fi | |
49 | ||
50 | ## Copy stdin to stdout, one line at a time. This is important in the shell | |
51 | ## game below, to prevent lines from two incoming streams being interleaved | |
52 | ## in the log file. | |
53 | copy () { while IFS= read -r line; do printf "%s %s\n" "$1" "$line"; done; } | |
54 | ||
55 | ###-------------------------------------------------------------------------- | |
56 | ### Lisp runes. | |
57 | ||
58 | ## Load and upgrade ASDF. | |
59 | load_asdf_rune="(require \"asdf\")" | |
60 | upgrade_asdf_rune="(asdf:upgrade-asdf)" | |
61 | ||
62 | ## Ignore `#!' lines. (We force this so as to provide a uniform environment, | |
63 | ## even though some Lisp implementations take special action when they know | |
64 | ## they're running scripts.) | |
65 | ignore_shebang_rune="\ | |
66 | (set-dispatch-macro-character | |
67 | #\\# #\\! | |
68 | (lambda (stream #1=#:char #2=#:arg) | |
69 | (declare (ignore #1# #2#)) | |
70 | (values (read-line stream))))" | |
71 | ||
72 | ## Push `:runlisp-script' into the `*features*' list. | |
73 | set_script_feature_rune="(pushnew :runlisp-script *features*)" | |
74 | ||
75 | ## All of the above. | |
76 | common_prelude_rune="\ | |
77 | (progn | |
78 | $upgrade_asdf_rune | |
79 | $ignore_shebang_rune | |
80 | $set_script_feature_rune)" | |
81 | ||
82 | ###-------------------------------------------------------------------------- | |
83 | ### Explain how to dump the various Lisp systems. | |
84 | ||
85 | ## Maintain the master tables. | |
86 | unset lisps | |
87 | deflisp () { lisps=${lisps+$lisps }$1; eval ${1}_image=\$2; } | |
88 | ||
89 | ## Steel Bank Common Lisp. | |
90 | deflisp sbcl sbcl+asdf.core | |
91 | dump_sbcl () { | |
92 | image=$(lisp_quote "$1") | |
93 | run "${SBCL-sbcl}" --noinform --no-userinit --no-sysinit \ | |
94 | --disable-debugger \ | |
95 | --eval "$load_asdf_rune" \ | |
96 | --eval "$common_prelude_rune" \ | |
97 | --eval "(sb-ext:save-lisp-and-die \"$image\")" | |
98 | } | |
99 | ||
100 | ## Clozure Common Lisp. | |
101 | deflisp ccl ccl+asdf.image | |
102 | dump_ccl () { | |
103 | image=$(lisp_quote "$1") | |
104 | ## A snaglet occurs here. CCL wants to use the image name as a clue to | |
105 | ## where the rest of its installation is; but in fact the image is | |
106 | ## nowhere near its installation. So we must hack... | |
107 | ||
108 | run "${CCL-ccl}" -b -n -Q \ | |
109 | -e "$load_asdf_rune" \ | |
110 | -e "$common_prelude_rune" \ | |
111 | -e "(ccl::in-development-mode | |
112 | (let ((#1=#:real-ccl-dir (ccl::ccl-directory))) | |
113 | (defun ccl::ccl-directory () | |
114 | (let* ((#2=#:dirpath (ccl:getenv \"CCL_DEFAULT_DIRECTORY\"))) | |
115 | (if (and #2# (plusp (length (namestring #2#)))) | |
116 | (ccl::native-to-directory-pathname #2#) | |
117 | #1#)))) | |
118 | (compile 'ccl::ccl-directory))" \ | |
119 | -e "(ccl:save-application \"$image\" | |
120 | :init-file nil | |
121 | :error-handler :quit)" | |
122 | } | |
123 | ||
124 | ## GNU CLisp. | |
125 | deflisp clisp clisp+asdf.mem | |
126 | dump_clisp () { | |
127 | image=$(lisp_quote "$1") | |
128 | run "${CLISP-clisp}" -norc -q -q \ | |
129 | -x "$load_asdf_rune" \ | |
130 | -x "$common_prelude_rune" \ | |
131 | -x "(ext:saveinitmem \"$image\" | |
132 | :norc t | |
133 | :script t)" \ | |
134 | -- wrong arguments | |
135 | } | |
136 | ||
137 | ## Embeddable Common Lisp. | |
138 | deflisp ecl ecl+asdf | |
139 | dump_ecl () { | |
140 | image=$1 | |
141 | set -e | |
142 | ||
143 | ## Start by compiling a copy of ASDF. | |
144 | cat >"$tmp/ecl-build.lisp" <<EOF | |
145 | (require "asdf") | |
146 | ||
147 | (defparameter *asdf* (asdf:find-system "asdf")) | |
148 | ||
149 | (defun right-here (pathname pattern) | |
150 | (declare (ignore pattern)) | |
151 | (merge-pathnames | |
152 | (make-pathname :name (concatenate 'string | |
153 | (string-downcase | |
154 | (lisp-implementation-type)) | |
155 | "-" | |
156 | (pathname-name pathname)) | |
157 | :type nil | |
158 | :version nil | |
159 | :defaults *default-pathname-defaults*) | |
160 | pathname)) | |
161 | (asdf:initialize-output-translations '(:output-translations | |
162 | ((#p"/" :**/ :*.*.*) | |
163 | (:function right-here)) | |
164 | :ignore-inherited-configuration)) | |
165 | ||
166 | (asdf:operate 'asdf:lib-op *asdf*) | |
167 | (si:quit 0) | |
168 | EOF | |
169 | (cd "$tmp" && run "${ECL-ecl}" ${eclopt}norc ${eclopt}load "ecl-build.lisp") | |
170 | ||
171 | ## And now compile our driver code. | |
172 | cat >"$tmp/ecl-run.lisp" <<EOF | |
173 | (cl:defpackage #:runlisp | |
174 | (:use #:common-lisp)) | |
175 | (cl:in-package #:runlisp) | |
176 | ||
177 | (defun main () | |
178 | $ignore_shebang_rune | |
179 | (asdf:register-immutable-system "asdf") | |
180 | (let ((pkg (find-package "COMMON-LISP-USER"))) | |
181 | (with-package-iterator (next pkg :internal) | |
182 | (loop (multiple-value-bind (anyp sym how) (next) | |
183 | (declare (ignore how)) | |
184 | (unless anyp (return)) | |
185 | (unintern sym pkg))))) | |
186 | $set_script_feature_rune | |
187 | (let ((winning t) (script nil) (marker nil) | |
188 | (prog (file-namestring (si:argv 0))) (i 1) (argc (si:argc))) | |
189 | (labels ((lose (msg &rest args) | |
190 | (format *error-output* "~&~A: ~?~%" prog msg args) | |
191 | (setf winning nil)) | |
192 | (quit (rc) | |
193 | (si:quit rc)) | |
194 | (usage (stream) | |
195 | (format stream "~&usage: ~A -s SCRIPT -- ARGS~%" | |
196 | prog)) | |
197 | (getarg () | |
198 | (and (< i argc) (prog1 (si:argv i) (incf i))))) | |
199 | (loop (let ((arg (getarg))) | |
200 | (cond ((null arg) (return)) | |
201 | ((string= arg "--") (setf marker t) (return)) | |
202 | ((string= arg "-s") (setf script (getarg))) | |
203 | ((string= arg "-h") (usage *standard-output*) (quit 0)) | |
204 | (t (lose "unrecognized option \`~A'" arg))))) | |
205 | (unless script (lose "nothing to do")) | |
206 | (unless marker (lose "unexpected end of options (missing \`--'?)")) | |
207 | (unless winning (usage *error-output*) (quit 255)) | |
208 | (handler-case | |
209 | (let ((*package* (find-package "COMMON-LISP-USER"))) | |
210 | (load script :verbose nil :print nil)) | |
211 | (error (err) | |
212 | (format *error-output* "~&~A (uncaught error): ~A~%" prog err) | |
213 | (quit 255))) | |
214 | (quit 0)))) | |
215 | (main) | |
216 | EOF | |
217 | (cd "$tmp" && run "${ECL-ecl}" ${eclopt}norc ${eclopt}load "ecl-asdf.fas" \ | |
218 | -s -o "ecl-run.o" ${eclopt}compile "ecl-run.lisp") | |
219 | ||
220 | ## Finally link everything together. | |
221 | run "${ECL-ecl}" ${eclopt}norc -o "$image"\ | |
222 | ${eclopt}link "$tmp/ecl-asdf.o" "$tmp/ecl-run.o" | |
223 | } | |
224 | ||
225 | ## Carnegie--Mellon University Common Lisp. | |
226 | deflisp cmucl cmucl+asdf.core | |
227 | dump_cmucl () { | |
228 | image=$(lisp_quote "$1") | |
229 | run "${CMUCL-cmucl}" -batch -noinit -nositeinit -quiet \ | |
230 | -eval "$load_asdf_rune" \ | |
231 | -eval "$common_prelude_rune" \ | |
232 | -eval "(ext:save-lisp \"$image\" | |
233 | :batch-mode t :print-herald nil | |
234 | :site-init nil :load-init-file nil)" | |
235 | } | |
236 | ||
237 | ###-------------------------------------------------------------------------- | |
238 | ### Command-line processing. | |
239 | ||
240 | usage () { echo "usage: $prog [-acluv] [-o FILE] [LISP ...]"; } | |
241 | version () { echo "$prog, runlisp version $VERSION"; } | |
242 | help () { | |
243 | version; echo; usage; cat <<EOF | |
244 | ||
245 | Options: | |
246 | -h Show this help text and exit successfully. | |
247 | -V Show the version number and exit successfully. | |
248 | -a Dump all installed Lisp implementations. | |
249 | -c Check that Lisp systems are installed before | |
250 | trying to dump. | |
251 | -l List known Lisp systems and default image filenames. | |
252 | -o OUT Store images in OUT (file or directory); default | |
253 | is \`\$RUNLISP_IMAGEDIR' or \`$imagedir' | |
254 | -u Only dump images which don't exist already. | |
255 | -v Be verbose, even if things go well. | |
256 | EOF | |
257 | } | |
258 | ||
259 | unset outfile; dir=${RUNLISP_IMAGEDIR-$imagedir}; dir=${dir%/}/ | |
260 | all=nil checkinst=nil bogus=nil out=nil update=nil verbose=nil | |
261 | ||
262 | ## Parse the options. | |
263 | while getopts "hVaclo:uv" opt; do | |
264 | case $opt in | |
265 | h) help; exit 0 ;; | |
266 | V) version; exit 0 ;; | |
267 | a) all=t checkinst=t ;; | |
268 | l) | |
269 | for i in $lisps; do | |
270 | eval out=\$${i}_image | |
271 | echo "$i -> $out" | |
272 | done | |
273 | exit 0 | |
274 | ;; | |
275 | o) outfile=$OPTARG out=t; dir= ;; | |
276 | u) update=t ;; | |
277 | v) verbose=t ;; | |
278 | *) bogus=t ;; | |
279 | esac | |
280 | done | |
281 | shift $(( $OPTIND - 1 )) | |
282 | ||
283 | ## If the destination is a directory then notice this. | |
284 | case $out in | |
285 | t) if [ -d "$outfile" ]; then dir=${outfile%/}/; out=nil; fi ;; | |
286 | esac | |
287 | ||
288 | ## Check that everything matches. | |
289 | case $#,$all,$out in | |
290 | 0,nil,*) lose "no Lisp systems to dump" ;; | |
291 | 0,t,nil) set -- $lisps ;; | |
292 | *,t,*) lose "\`-a' makes no sense with explicit list" ;; | |
293 | 1,nil,t) ;; | |
294 | *,*,t) lose "can't name explicit output file for multiple Lisp systems" ;; | |
295 | esac | |
296 | ||
297 | ## Check that the Lisp systems named are actually known. | |
298 | for lisp in "$@"; do | |
299 | case " $lisps " in | |
300 | *" $lisp "*) ;; | |
301 | *) echo >&2 "$prog: unknown Lisp \`$lisp'"; exit 2 ;; | |
302 | esac | |
303 | done | |
304 | ||
305 | ## Complain if there were problems. | |
306 | case $bogus in t) usage >&2; exit 2 ;; esac | |
307 | ||
308 | ###-------------------------------------------------------------------------- | |
309 | ### Dump the images. | |
310 | ||
311 | ## Establish a temporary directory to work in. | |
312 | i=0 | |
313 | while :; do | |
314 | tmp=${TMPDIR-/tmp}/runlisp-tmp.$$. | |
315 | if mkdir "$tmp" >/dev/null 2>&1; then break; fi | |
316 | case $i in 64) lose "failed to create temporary directory" ;; esac | |
317 | i=$(expr $i + 1) | |
318 | done | |
319 | trap 'rm -rf "$tmp"' EXIT INT TERM HUP | |
320 | ||
321 | ## Send stdout to stderr or the log, depending on verbosity. | |
322 | output () { | |
323 | case $verbose in | |
324 | nil) $lbuf cat -u >"$tmp/log" ;; | |
325 | t) $lbuf cat >&2 ;; | |
326 | esac | |
327 | } | |
328 | ||
329 | ## Work through each requested Lisp system. | |
330 | exit=0 | |
331 | for lisp in "$@"; do | |
332 | ||
333 | ## Figure out the output file to use. | |
334 | case $out in nil) eval outfile=\$dir\$${lisp}_image ;; esac | |
335 | ||
336 | ## Maybe we skip this one if the output already exists. | |
337 | case $update in | |
338 | t) | |
339 | if [ -f "$outfile" ]; then | |
340 | case $verbose in | |
341 | t) | |
342 | echo >&2 "$prog: \`$outfile' already exists: skipping \`$lisp'" | |
343 | ;; | |
344 | esac | |
345 | continue | |
346 | fi | |
347 | ;; | |
348 | esac | |
349 | ||
350 | ## If we're doing all the Lisps, then skip systems which aren't actually | |
351 | ## installed. | |
352 | case $checkinst in | |
353 | t) | |
354 | LISP=$(echo $lisp | tr a-z A-Z) | |
355 | eval lispprog=\${$LISP-$lisp} | |
356 | if ! type >/dev/null 2>&1 $lispprog; then | |
357 | case $verbose in | |
358 | t) | |
359 | echo >&2 "$prog: command \`$LISP' not found: skipping \`$lisp'" | |
360 | ;; | |
361 | esac | |
362 | continue | |
363 | fi | |
364 | ;; | |
365 | esac | |
366 | ||
367 | ## Dump the Lisp, capturing its potentially drivellous output in a log | |
368 | ## (unless we're being verbose). Be careful to keep stdout and stderr | |
369 | ## separate. | |
370 | rc=$( | |
371 | { { { { echo "dumping $lisp to \`$outfile'..." | |
372 | set +e; dump_$lisp "$outfile" 4>&- 5>&- | |
373 | echo $? >&5; } | | |
374 | copy "|" >&4; } 2>&1 | | |
375 | copy "*" >&4; } 4>&1 | | |
376 | output; } 5>&1 </dev/null | |
377 | ) | |
378 | ||
379 | ## If it failed, and we didn't already spray the output to the terminal, | |
380 | ## then do that now; also record that we encountered a problem. | |
381 | case $rc in | |
382 | 0) ;; | |
383 | *) case $verbose in nil) cat >&2 "$tmp/log" ;; esac; exit=2 ;; | |
384 | esac | |
385 | done | |
386 | ||
387 | ## All done. | |
388 | exit $exit | |
389 | ||
390 | ###----- That's all, folks -------------------------------------------------- |