;;; -*- mode: Lisp; Syntax: Common-Lisp; -*- ;;; ;;; Copyright (c) 2009 by the authors. ;;; ;;; See LICENCE for details. ;; To bootstrap the hu.dwim.build executable (after the bootstrap, hu.dwim.build.sh can be replaced with the built hu.dwim.build executable): ;; /opt/hu.dwim.home/workspace/hu.dwim.build/bin/build.sh ;;;;;; ;;; Builds executable or image files for development and production environments ; TODO ; you could call asdf/image::compute-command-line-arguments ;(2013-02-26 03:41:17) François-René Rideau (Faré): really, you SHOULD be calling asdf/image:restore-image ;(2013-02-26 03:41:40) François-René Rideau (Faré): it has other functions registered to its restore-image hook. (in-package :hu.dwim.build) ;;;;;; ;;; Command line options (defvar +build-command-line-options+ '((("help" #\h) :type boolean :optional t :documentation "Print usage help and exit") (("development-build" #\d) :type boolean :optional t :documentation "Instead of loading the system with the given name, load all dependencies for all systems whose name start with it. At the same time do not load systems whose name also start with the given name. In other words load all dependencies which are not part of the development to speed up startup time, but do not load any of those systems which are part of the development to avoid redefinitions.") (("excluded-systems" #\Space) :type string :optional t :documentation "A comma separated list of ASDF system names that should not be loaded. Useful for e.g. excluding Swank when building with --development-build.") (("input-filename" #\i) :type string :optional t :documentation "Input core image filename. Not used by default.") (("output-filename" #\o) :type string :optional t :documentation "Output core image or executable filename. Executable files are built next to 'workspace' with the given system name by default. Core image files are built under 'workspace/hu.dwim.environment/core' with the given system name by default.") (("overwrite-output-file" #\w) :type boolean :optional t :documentation "Overwrite the output file if already exists. Not overwritten by default.") (("executable-output" #\e) :type boolean :optional t :documentation "Build an executable instead of a core image file.") (("maximum-memory-size" #\Space) :type string :optional t :documentation "The default value of the allowed maximum memory usage of the executable being built, either as a byte number or with a size postfix K (10^3), M (10^6), G (10^9), Ki (2^10), Mi (2^20), Gi (2^30); e. g. 250M") #+sbcl ; TODO save-runtime-options is the wrong answer for this problem... (("save-runtime-options" #\Space) :type boolean :optional nil :documentation "Only applies when --executable-output is true. When true SBCL's runtime option processing is disabled and the original values of the runtime options (that were active when the executable core was saved) are stored in the core. True by default.") #+sbcl (("sbcl-home" #\Space) :type string :optional nil :documentation "The value of the SBCL_HOME variable in the shell environment of the spawned child SBCL process. If not specified and the SBCL_HOME environment variable is not set either, then its value will be inherited from the environment from the time of loading (building) hu.dwim.build.") #+sbcl (("userinit" #\u) :type boolean :optional nil :documentation "During the SBCL build, allow the user init file .sbclrc to be executed (by omitting --no-userinit). This is helpful if you want to use quicklisp to load dependencies") (("production-build" #\p) :type boolean :optional t :documentation "Build output for production environment. Useful for conditional compilation constructs.") (("toplevel-function" #\t) :type string :optional t :documentation "Fully qualified toplevel function name that will be called by the executable. Uses the function EXECUTABLE-TOPLEVEL in the system's package by default.") (("load-swank" #\l) :type boolean :optional t :documentation "Include swank in the output image, but do not start a server automatically.") (("swank-directory" #\Space) :type string :optional t :documentation "Directory name from where to load Slime. Defaults to 'hu.dwim.slime/', but only takes effect when --load-swank was requested."))) ;;;;;; ;;; Util (defun quit (status-code &optional error-message &rest args) (when error-message (format *error-output* "*** ~A~%" (apply #'format nil error-message args))) (sb-ext:exit :code status-code)) (defun ensure-default-external-format-is-utf-8 () (unless (eq (sb-impl::default-external-format) :utf-8) (cerror "Ignore" "The default external format is ~S, but UTF-8 is strongly advised! Check your $LANG env variable..." (sb-impl::default-external-format)))) (defun maybe-find-system (name) (with-simple-restart (skip-system "Skip calling ~S on ~S" 'find-system name) #-quicklisp (find-system name) #+quicklisp (handler-case (find-system name) (missing-component () (ql:quickload name))))) (defun find-all-systems-with-prefix (system-name-prefix) (map-asdf-source-registry-directories (lambda (directory) (dolist (file (directory (merge-pathnames directory (make-pathname :name :wild :type "asd")))) (let ((name (pathname-name file))) (when (search system-name-prefix name) (maybe-find-system name))))))) (defun collect-to-be-loaded-systems-for-development-build (target-system-name) "Collects systems names that are dependencies of all the systems whose name starts with TARGET-SYSTEM-NAME." (let ((to-be-loaded-systems nil)) (find-all-systems-with-prefix target-system-name) (asdf:map-systems (lambda (system) ;; NOTE: zerop errors on nil, not ok here (when (eql 0 (search target-system-name (asdf:component-name system))) (handler-bind ((missing-component (lambda (c) (progn #+quicklisp (ql:quickload (asdf::missing-requires c)) (invoke-restart 'retry))))) (hu.dwim.asdf:map-system-dependencies (lambda (dependent-system) (let ((dependent-system-name (asdf:component-name dependent-system))) (with-simple-restart (skip-system "Skip finding system ~S" dependent-system-name) (unless (search target-system-name (component-name dependent-system)) (pushnew dependent-system-name to-be-loaded-systems))))) system))))) to-be-loaded-systems)) (defun print-usage-help () (format *standard-output* "Usage: hu.dwim.build [OPTION]... SYSTEM-NAME~% Load the system with the given name and build a core image or executable file. The output core image file can be loaded by both SBCL and hu.dwim.build.~%~%") (let ((*print-right-margin* 120)) (show-option-help +build-command-line-options+ :sort-names t)) (format *standard-output* "~%Report bugs at http://dwim.hu/~%")) (defun parse-integer/with-size-postfix (string) (when string (multiple-value-bind (value scale-start-position) (parse-integer string :junk-allowed t) (unless value (error "Unable to parse out an integer from the beginning of ~S" string)) (let* ((scale-entry (assoc (subseq string scale-start-position) `(("K" ,(expt 10 3)) ("M" ,(expt 10 6)) ("G" ,(expt 10 9)) ("Ki" ,(expt 2 10)) ("Mi" ,(expt 2 20)) ("Gi" ,(expt 2 30))) :test 'equalp)) (scale (or (second scale-entry) 1))) (* value scale))))) (defun split-sequence (sequence &key (separator #\,)) (let ((pieces '())) (loop :with previous-position = 0 :for index :from 0 :below (length sequence) :for char = (elt sequence index) :when (char= char separator) :do (progn (push (subseq sequence previous-position index) pieces) (setf previous-position (1+ index))) :finally (push (subseq sequence previous-position) pieces)) (nreverse (remove 0 pieces :key 'length)))) ;;;;;; ;;; Build image (defvar *sbcl-home* (sb-posix:getenv "SBCL_HOME")) ;; TODO add support for (sb-ext:restrict-compiler-policy 'safety 2) (defun build () #-sbcl (error "Unsupported Common Lisp implementation") (multiple-value-bind (option-arguments mandatory-arguments) (process-command-line-options +build-command-line-options+ (get-command-line-arguments)) (let* ((target-system-name (first mandatory-arguments)) ;; TODO why not a destructuring-bind instead of all this getf'ing? (development-build? (getf option-arguments :development-build)) (executable-output? (getf option-arguments :executable-output)) (userinit? (getf option-arguments :userinit)) (maximum-memory-size (let ((maximum-memory-size-string (getf option-arguments :maximum-memory-size))) (when maximum-memory-size-string (parse-integer/with-size-postfix maximum-memory-size-string)))) (save-runtime-options? (or (getf option-arguments :save-runtime-options) executable-output? maximum-memory-size)) (toplevel-function (getf option-arguments :toplevel-function)) (swank-directory (getf option-arguments :swank-directory)) (load-swank? (getf option-arguments :load-swank)) (excluded-systems (split-sequence (getf option-arguments :excluded-systems ""))) (input-filename (getf option-arguments :input-filename)) (output-filename (or (getf option-arguments :output-filename) (merge-pathnames (apply 'concatenate 'string (append (list target-system-name (when development-build? "_development")) #+nil ; would be nice, but if swank-directory is not specified explicitly by the user, then we have no idea about its real value here... (when load-swank? (list "_" (remove-if (lambda (char) (and (not (alphanumericp char)) (not (find char "._-+!")))) swank-directory))) (unless executable-output? (list ".core")))) ;; store under ~/.cache/common-lisp/sbcl-1.0.43.25-linux-x86-64/ (asdf:apply-output-translations "/")))) (overwrite-output-file? (getf option-arguments :overwrite-output-file)) (help? (getf option-arguments :help)) (production-build? (getf option-arguments :production-build))) (ensure-default-external-format-is-utf-8) (when help? (print-usage-help) (quit 0)) (progn (let ((sbcl-home (getf option-arguments :sbcl-home))) (when sbcl-home (unless (probe-file sbcl-home) (quit -1 "The directory specified by --sbcl-home is not available: ~S" sbcl-home)) (setf *sbcl-home* sbcl-home))) (cond ((equal *sbcl-home* "") (setf *sbcl-home* nil)) ((not (probe-file *sbcl-home*)) (format *debug-io* "; The value of SBCL_HOME when building hu.dwim.build was ~S, but it's not available anymore! Will try the current value of SBCL_HOME...~%" *sbcl-home*) (setf *sbcl-home* nil))) (unless *sbcl-home* (setf *sbcl-home* (sb-posix:getenv "SBCL_HOME")) (format *debug-io* "; As a last resort, took the value of SBCL_HOME from the current shell environment: ~S~%" *sbcl-home*)) (when (or (null *sbcl-home*) (string= *sbcl-home* "")) (quit -1 "hu.dwim.build: Unable to find a usable SBCL_HOME, giving up...")) (when maximum-memory-size (unless executable-output? (quit -1 "hu.dwim.build: --maximum-memory-size only makes sense when --executable-output is true"))) (when (and save-runtime-options? (not executable-output?)) (quit -1 "hu.dwim.build: --save-runtime-options only makes sense when --executable-output is true"))) (unless target-system-name (quit -1 "hu.dwim.build: System name argument not provided")) (when input-filename (unless (probe-file input-filename) (quit -1 "hu.dwim.build: Input file does not exists"))) (when (and (probe-file output-filename) (not overwrite-output-file?)) (quit -1 "hu.dwim.build: Output file already exists")) (format *debug-io* "; The following systems have been specified to be excluded from the build: ~S~%" excluded-systems) (let* ((to-be-loaded-systems (if development-build? (remove-if (lambda (system-name) (member (string system-name) excluded-systems :test 'equalp)) (collect-to-be-loaded-systems-for-development-build target-system-name)) (list target-system-name))) ;; TODO provide some (customizable?) default restarts like ABORT, save-image-and-die, maybe give-up... around the toplevel-function (toplevel-function (or (when toplevel-function `(read-from-string ,toplevel-function)) (when (and executable-output? (not development-build?)) (let ((system (find-system target-system-name))) (when (typep system 'hu.dwim.system) `(or (find-symbol "EXECUTABLE-TOPLEVEL" ,(system-package-name system)) 'sb-impl::toplevel-init)))) ''sb-impl::toplevel-init)) (load-swank '(let ((*package* (find-package :hu.dwim.asdf))) (format *debug-io* "; Loading swank...~%") (load (system-relative-pathname :swank "swank-loader.lisp")) (format *debug-io* "; Setting up swank...~%") (eval (read-from-string "(progn (swank-loader:init :load-contribs nil))")) (eval (read-from-string ;; load swank contribs at image building time, so that slime-connect will not bark "(progn (swank:swank-require '(:swank-fancy-inspector :swank-fuzzy :swank-indentation :swank-presentations :swank-clipboard :swank-sprof :swank-c-p-c #+sbcl :swank-sbcl-exts )) ;; TODO not in production builds. should it be configurable maybe? (setf swank:*globally-redirect-io* t) )")))) (build-program `(restart-bind ((:start-swank-server (lambda () ;; FIXME: without releasing **world-lock** method caches cannot be populated, and e.g connecting to swank ;; is stuck. the started resulting image is also stuck when trying to call some generics for parsing cmd ine args. ;; this is serious kludgery, but... see below another instance (when (eq (sb-thread:mutex-owner sb-c::**world-lock**) sb-thread:*current-thread*) (warn "Realeasing ~S held by the current thread ~A" 'sb-c::**world-lock** sb-thread:*current-thread*) (sb-thread:release-mutex sb-c::**world-lock**)) (asdf:load-system :hu.dwim.util.production+swank) (eval (read-from-string "(hu.dwim.util:start-swank-server 4005)"))) :report-function (lambda (stream) (format stream "Start Swank server on port 4005 and abort the current operation")))) (hu.dwim.asdf::with-muffled-boring-compiler-warnings ,@(when load-swank? (list load-swank)) (require :sb-sprof) (let ((*load-as-production?* ,production-build?)) (dolist (system ',to-be-loaded-systems) (with-simple-restart (:skip-system "Skip calling ~S on ~S" 'load-system system) #-quicklisp (load-system system) #+quicklisp (handler-case (load-system system) (missing-component () (ql:quickload system))))) (when (and ,overwrite-output-file? (probe-file ,output-filename)) (delete-file ,output-filename)) (in-package :common-lisp-user) (format *debug-io* "; GC'ing~%") ;; reduce memory usage by not doing a full copying gc in one step inside sb-ext:save-lisp-and-die (sb-ext:gc :gen 4) (sb-ext:gc :gen 5) (format *debug-io* "; Calling SB-EXT:SAVE-LISP-AND-DIE~%") (ensure-directories-exist ,output-filename) (push (lambda () (unless (sb-posix:getenv "SBCL_HOME") (sb-posix:setenv "SBCL_HOME" ,*sbcl-home* 1))) sb-ext:*init-hooks*) ;; FIXME: without releasing **world-lock** method caches cannot be populated, and e.g connecting to swank ;; is stuck. the started resulting image is also stuck when trying to call some generics for parsing cmd ine args. ;; this is serious kludgery, but... see above another instance (when (eq (sb-thread:mutex-owner sb-c::**world-lock**) sb-thread:*current-thread*) (warn "Realeasing ~S held by the current thread ~A" 'sb-c::**world-lock** sb-thread:*current-thread*) (sb-thread:release-mutex sb-c::**world-lock**)) (sb-ext:save-lisp-and-die ,output-filename :executable ,executable-output? :save-runtime-options ,save-runtime-options? :toplevel ,toplevel-function))))) (setup-program/stage1 `(make-package :hu.dwim.asdf)) (setup-program/stage2 `(progn ,(when swank-directory `(defparameter hu.dwim.asdf::*swank-directory* ,swank-directory)) (load ,(truename (system-relative-pathname :hu.dwim.build "../hu.dwim.environment/source/environment.lisp"))) ;; needed for setenv in the build form (require :sb-posix))) (run-sbcl-shell-script (handler-case (namestring (truename (merge-pathnames "../run-sbcl.sh" (pathname *sbcl-home*)))) (file-error () nil))) (program-to-run (if run-sbcl-shell-script "/bin/sh" sb-ext:*runtime-pathname*)) (shell-arguments (let* ((*package* (find-package :keyword))) `(,@(if run-sbcl-shell-script (list run-sbcl-shell-script) nil) ,@(when maximum-memory-size (list "--dynamic-space-size" (princ-to-string (round (/ maximum-memory-size (* 1024 1024)))))) ,@(when input-filename (list "--core" input-filename)) "--end-runtime-options" "--no-sysinit" ,@(unless userinit? (list "--no-userinit")) "--eval" ,(write-to-string setup-program/stage1) "--eval" ,(write-to-string setup-program/stage2) "--eval" ,(write-to-string build-program))))) ;; NOTE: ~S allows copying the forms into a shell (format *debug-io* "; Running build with: ~S ~{~S ~}~%" program-to-run shell-arguments) (format *debug-io* "; *sbcl-home* is: ~S~%" *sbcl-home*) (sb-ext:run-program program-to-run shell-arguments :input t :output t :environment (remove nil (list* (when *sbcl-home* (concatenate 'string "SBCL_HOME=" *sbcl-home*)) (sb-ext:posix-environ))) :wait t) (quit 0))))) (defun executable-toplevel () #+sbcl(sb-ext:disable-debugger) (build))