| 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 -------------------------------------------------- |