#! /bin/sh -e
###
### Dump Lisp images for faster script execution
###
### (c) 2020 Mark Wooding
###

###----- Licensing notice ---------------------------------------------------
###
### This file is part of Runlisp, a tool for invoking Common Lisp scripts.
###
### Runlisp is free software: you can redistribute it and/or modify it
### under the terms of the GNU General Public License as published by the
### Free Software Foundation; either version 3 of the License, or (at your
### option) any later version.
###
### Runlisp is distributed in the hope that it will be useful, but WITHOUT
### ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
### FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
### for more details.
###
### You should have received a copy of the GNU General Public License
### along with Runlisp.  If not, see <https://www.gnu.org/licenses/>.

###--------------------------------------------------------------------------
### Build-time configuration.

VERSION=@VERSION@
imagedir=@imagedir@
eclopt=@ECLOPT@

###--------------------------------------------------------------------------
### Random utilities.

prog=${0##*/}

## Report a fatal error.
lose () { echo >&2 "$prog: $*"; exit 2; }

## Quote a string so that Lisp will understand it.
lisp_quote () { printf "%s\n" "$1" | sed 's/[\\"]/\\&/g'; }

## Mention that we're running a program.
run () { echo "$*"; $lbuf "$@"; }

## Figure out whether we can force line-buffering.
if stdbuf --version >/dev/null 2>&1; then lbuf="stdbuf -oL --"
else lbuf=""; fi

## Copy stdin to stdout, one line at a time.  This is important in the shell
## game below, to prevent lines from two incoming streams being interleaved
## in the log file.
copy () { while IFS= read -r line; do printf "%s %s\n" "$1" "$line"; done; }

###--------------------------------------------------------------------------
### Lisp runes.

## Load and upgrade ASDF.
load_asdf_rune="(require \"asdf\")"
upgrade_asdf_rune="(asdf:upgrade-asdf)"

## Ignore `#!' lines.  (We force this so as to provide a uniform environment,
## even though some Lisp implementations take special action when they know
## they're running scripts.)
ignore_shebang_rune="\
(set-dispatch-macro-character
 #\\# #\\!
 (lambda (stream #1=#:char #2=#:arg)
   (declare (ignore #1# #2#))
   (values (read-line stream))))"

## Push `:runlisp-script' into the `*features*' list.
set_script_feature_rune="(pushnew :runlisp-script *features*)"

## All of the above.
common_prelude_rune="\
(progn
  $upgrade_asdf_rune
  $ignore_shebang_rune
  $set_script_feature_rune)"

###--------------------------------------------------------------------------
### Explain how to dump the various Lisp systems.

## Maintain the master tables.
unset lisps
deflisp () { lisps=${lisps+$lisps }$1; eval ${1}_image=\$2; }

## Steel Bank Common Lisp.
deflisp sbcl sbcl+asdf.core
dump_sbcl () {
  image=$(lisp_quote "$1")
  run "${SBCL-sbcl}" --noinform --no-userinit --no-sysinit \
    --disable-debugger \
    --eval "$load_asdf_rune" \
    --eval "$common_prelude_rune" \
    --eval "(sb-ext:save-lisp-and-die \"$image\")"
}

## Clozure Common Lisp.
deflisp ccl ccl+asdf.image
dump_ccl () {
  image=$(lisp_quote "$1")
  ## A snaglet occurs here.  CCL wants to use the image name as a clue to
  ## where the rest of its installation is; but in fact the image is
  ## nowhere near its installation.  So we must hack...

  run "${CCL-ccl}" -b -n -Q \
    -e "$load_asdf_rune" \
    -e "$common_prelude_rune" \
    -e "(ccl::in-development-mode
	  (let ((#1=#:real-ccl-dir (ccl::ccl-directory)))
	    (defun ccl::ccl-directory ()
	      (let* ((#2=#:dirpath (ccl:getenv \"CCL_DEFAULT_DIRECTORY\")))
		(if (and #2# (plusp (length (namestring #2#))))
		    (ccl::native-to-directory-pathname #2#)
		    #1#))))
	  (compile 'ccl::ccl-directory))" \
    -e "(ccl:save-application \"$image\"
	  :init-file nil
	  :error-handler :quit)"
}

## GNU CLisp.
deflisp clisp clisp+asdf.mem
dump_clisp () {
  image=$(lisp_quote "$1")
  run "${CLISP-clisp}" -norc -q -q \
    -x "$load_asdf_rune" \
    -x "$common_prelude_rune" \
    -x "(ext:saveinitmem \"$image\"
	  :norc t
	  :script t)" \
    -- wrong arguments
}

## Embeddable Common Lisp.
deflisp ecl ecl+asdf
dump_ecl () {
  image=$1
  set -e

  ## Start by compiling a copy of ASDF.
  cat >"$tmp/ecl-build.lisp" <<EOF
(require "asdf")

(defparameter *asdf* (asdf:find-system "asdf"))

(defun right-here (pathname pattern)
  (declare (ignore pattern))
  (merge-pathnames
   (make-pathname :name (concatenate 'string
				     (string-downcase
				      (lisp-implementation-type))
				     "-"
				     (pathname-name pathname))
		  :type nil
		  :version nil
		  :defaults *default-pathname-defaults*)
   pathname))
(asdf:initialize-output-translations '(:output-translations
				       ((#p"/" :**/ :*.*.*)
					(:function right-here))
				       :ignore-inherited-configuration))

(asdf:operate 'asdf:lib-op *asdf*)
(si:quit 0)
EOF
  (cd "$tmp" && run "${ECL-ecl}" ${eclopt}norc ${eclopt}load "ecl-build.lisp")

  ## And now compile our driver code.
  cat >"$tmp/ecl-run.lisp" <<EOF
(cl:defpackage #:runlisp
  (:use #:common-lisp))
(cl:in-package #:runlisp)

(defun main ()
  $ignore_shebang_rune
  (asdf:register-immutable-system "asdf")
  (let ((pkg (find-package "COMMON-LISP-USER")))
    (with-package-iterator (next pkg :internal)
      (loop (multiple-value-bind (anyp sym how) (next)
	      (declare (ignore how))
	      (unless anyp (return))
	      (unintern sym pkg)))))
  $set_script_feature_rune
  (let ((winning t) (script nil) (marker nil)
	(prog (file-namestring (si:argv 0))) (i 1) (argc (si:argc)))
    (labels ((lose (msg &rest args)
	       (format *error-output* "~&~A: ~?~%" prog msg args)
	       (setf winning nil))
	     (quit (rc)
	       (si:quit rc))
	     (usage (stream)
	       (format stream "~&usage: ~A -s SCRIPT -- ARGS~%"
		       prog))
	     (getarg ()
	       (and (< i argc) (prog1 (si:argv i) (incf i)))))
      (loop (let ((arg (getarg)))
	      (cond ((null arg) (return))
		    ((string= arg "--") (setf marker t) (return))
		    ((string= arg "-s") (setf script (getarg)))
		    ((string= arg "-h") (usage *standard-output*) (quit 0))
		    (t (lose "unrecognized option \`~A'" arg)))))
      (unless script (lose "nothing to do"))
      (unless marker (lose "unexpected end of options (missing \`--'?)"))
      (unless winning (usage *error-output*) (quit 255))
      (handler-case
	  (let ((*package* (find-package "COMMON-LISP-USER")))
	    (load script :verbose nil :print nil))
	(error (err)
	  (format *error-output* "~&~A (uncaught error): ~A~%" prog err)
	  (quit 255)))
      (quit 0))))
(main)
EOF
  (cd "$tmp" && run "${ECL-ecl}" ${eclopt}norc ${eclopt}load "ecl-asdf.fas" \
    -s -o "ecl-run.o" ${eclopt}compile "ecl-run.lisp")

  ## Finally link everything together.
  run "${ECL-ecl}" ${eclopt}norc -o "$image"\
    ${eclopt}link "$tmp/ecl-asdf.o" "$tmp/ecl-run.o"
}

## Carnegie--Mellon University Common Lisp.
deflisp cmucl cmucl+asdf.core
dump_cmucl () {
  image=$(lisp_quote "$1")
  run "${CMUCL-cmucl}" -batch -noinit -nositeinit -quiet \
    -eval "$load_asdf_rune" \
    -eval "$common_prelude_rune" \
    -eval "(ext:save-lisp \"$image\"
	     :batch-mode t :print-herald nil
	     :site-init nil :load-init-file nil)"
}

###--------------------------------------------------------------------------
### Command-line processing.

usage () { echo "usage: $prog [-acluv] [-o FILE] [LISP ...]"; }
version () { echo "$prog, runlisp version $VERSION"; }
help () {
  version; echo; usage; cat <<EOF

Options:
  -h			Show this help text and exit successfully.
  -V			Show the version number and exit successfully.
  -a			Dump all installed Lisp implementations.
  -c			Check that Lisp systems are installed before
			  trying to dump.
  -l			List known Lisp systems and default image filenames.
  -o OUT		Store images in OUT (file or directory); default
			  is \`\$RUNLISP_IMAGEDIR' or \`$imagedir'
  -u			Only dump images which don't exist already.
  -v			Be verbose, even if things go well.
EOF
}

unset outfile; dir=${RUNLISP_IMAGEDIR-$imagedir}; dir=${dir%/}/
all=nil checkinst=nil bogus=nil out=nil update=nil verbose=nil

## Parse the options.
while getopts "hVaclo:uv" opt; do
  case $opt in
    h) help; exit 0 ;;
    V) version; exit 0 ;;
    a) all=t checkinst=t ;;
    l)
      for i in $lisps; do
	eval out=\$${i}_image
	echo "$i -> $out"
      done
      exit 0
      ;;
    o) outfile=$OPTARG out=t; dir= ;;
    u) update=t ;;
    v) verbose=t ;;
    *) bogus=t ;;
  esac
done
shift $(( $OPTIND - 1 ))

## If the destination is a directory then notice this.
case $out in
  t) if [ -d "$outfile" ]; then dir=${outfile%/}/; out=nil; fi ;;
esac

## Check that everything matches.
case $#,$all,$out in
  0,nil,*) lose "no Lisp systems to dump" ;;
  0,t,nil) set -- $lisps ;;
  *,t,*) lose "\`-a' makes no sense with explicit list" ;;
  1,nil,t) ;;
  *,*,t) lose "can't name explicit output file for multiple Lisp systems" ;;
esac

## Check that the Lisp systems named are actually known.
for lisp in "$@"; do
  case " $lisps " in
    *" $lisp "*) ;;
    *) echo >&2 "$prog: unknown Lisp \`$lisp'"; exit 2 ;;
  esac
done

## Complain if there were problems.
case $bogus in t) usage >&2; exit 2 ;; esac

###--------------------------------------------------------------------------
### Dump the images.

## Establish a temporary directory to work in.
i=0
while :; do
  tmp=${TMPDIR-/tmp}/runlisp-tmp.$$.
  if mkdir "$tmp" >/dev/null 2>&1; then break; fi
  case $i in 64) lose "failed to create temporary directory" ;; esac
  i=$(expr $i + 1)
done
trap 'rm -rf "$tmp"' EXIT INT TERM HUP

## Send stdout to stderr or the log, depending on verbosity.
output () {
  case $verbose in
    nil) $lbuf cat -u >"$tmp/log" ;;
    t) $lbuf cat >&2 ;;
  esac
}

## Work through each requested Lisp system.
exit=0
for lisp in "$@"; do

  ## Figure out the output file to use.
  case $out in nil) eval outfile=\$dir\$${lisp}_image ;; esac

  ## Maybe we skip this one if the output already exists.
  case $update in
    t)
      if [ -f "$outfile" ]; then
	case $verbose in
	  t)
	    echo >&2 "$prog: \`$outfile' already exists: skipping \`$lisp'"
	    ;;
	esac
	continue
      fi
      ;;
  esac

  ## If we're doing all the Lisps, then skip systems which aren't actually
  ## installed.
  case $checkinst in
    t)
      LISP=$(echo $lisp | tr a-z A-Z)
      eval lispprog=\${$LISP-$lisp}
      if ! type >/dev/null 2>&1 $lispprog; then
	case $verbose in
	  t)
	    echo >&2 "$prog: command \`$LISP' not found: skipping \`$lisp'"
	    ;;
	esac
	continue
      fi
      ;;
  esac

  ## Dump the Lisp, capturing its potentially drivellous output in a log
  ## (unless we're being verbose).  Be careful to keep stdout and stderr
  ## separate.
  rc=$(
    { { { { echo "dumping $lisp to \`$outfile'..."
	    set +e; dump_$lisp "$outfile" 4>&- 5>&-
	    echo $? >&5; } |
	  copy "|" >&4; } 2>&1 |
	copy "*" >&4; } 4>&1 |
      output; } 5>&1 </dev/null
  )

  ## If it failed, and we didn't already spray the output to the terminal,
  ## then do that now; also record that we encountered a problem.
  case $rc in
    0) ;;
    *) case $verbose in nil) cat >&2 "$tmp/log" ;; esac; exit=2 ;;
  esac
done

## All done.
exit $exit

###----- That's all, folks --------------------------------------------------