Allow building a executable with Kiln

Author: ruricolist

bootstrap/build0.lisp

@@ -18,20 +18,24 @@
             required-version)
     (finish-output *error-output*)
     (uiop:quit 1)))
-(defparameter *target-system* (uiop:getenv "KILN_TARGET_SYSTEM"))
-(assert (stringp *target-system*))
-(assert (not (= 0 (length *target-system*))))
-(if (find-package :ql)
-    (progn
-      (format *error-output* "Found Quicklisp~%")
-      (uiop:symbol-call :ql :register-local-projects)
-      (multiple-value-call #'uiop:symbol-call
-        :ql :quickload *target-system*
-        (if (uiop:getenvp "KILN_DEBUG") (values)
-            (values :silent t))))
-  (progn
-    (format *error-output* "Quicklisp not found~%")
-    (asdf:load-system *target-system*)))
-(kiln/image:load-all-script-systems)
+(defun load-system (system)
+  (assert (stringp system))
+  (assert (not (= 0 (length system))))
+  (if (find-package :ql)
+      (progn
+        (format *error-output* "Found Quicklisp~%")
+        (uiop:symbol-call :ql :register-local-projects)
+        (multiple-value-call #'uiop:symbol-call
+          :ql :quickload system
+          (if (uiop:getenvp "KILN_DEBUG") (values)
+              (values :silent t))))
+      (progn
+        (format *error-output* "Quicklisp not found~%")
+        (asdf:load-system system))))
+(load-system "kiln/build")
+(let ((target-system (uiop:getenvp "KILN_TARGET_SYSTEM")))
+  (if target-system
+      (load-system target-system)
+      (kiln/image:load-all-script-systems)))
 (finish-output *error-output*)
 (uiop:quit)

bootstrap/build1.lisp

@@ -19,14 +19,11 @@
                         "2.2.6")
                        -7
                        1)))
-(defparameter *target-system* (uiop:getenv "KILN_TARGET_SYSTEM"))
-(assert (stringp *target-system*))
-(assert (not (= 0 (length *target-system*))))
 (setf (asdf/system:component-build-pathname
-       (asdf:find-system *target-system*))
+       (asdf:find-system "kiln/build"))
       (let ((string (uiop:getenvp "KILN_TARGET_FILE")))
         (if string
             (uiop:parse-unix-namestring string)
             #p"kiln")))
-(asdf:make *target-system* :type :program :monolithic t)
+(asdf:make "kiln/build" :type :program :monolithic t)
 (uiop:quit)

build.sh

@@ -6,13 +6,13 @@ set -eu
 : "${KILN_LISP:=sbcl}"
 : "${KILN_HEAP_SIZE:=32768}"
 : "${KILN_STACK_SIZE:=}"
+: "${KILN_TARGET_SYSTEM:=}"
 
 if test -n "$KILN_DEBUG"; then
     set -x
+    env | grep ^KILN_ >&2
 fi
 
-export KILN_TARGET_SYSTEM="${KILN_TARGET_SYSTEM:-"kiln/build"}"
-
 # We will rebind KILN_TARGET_FILE to a tmpfile during the build.
 real_target_file="${KILN_TARGET_FILE:-"kiln"}"
 
@@ -59,6 +59,8 @@ fi
 : "${CL_SOURCE_REGISTRY:="$(pwd):"}"
 export CL_SOURCE_REGISTRY
 
+export KILN_TARGET_SYSTEM
+
 # Load once, then dump to avoid serializing foreign pointers.
 
 echo "Updating fasls" >&2
@@ -70,7 +72,7 @@ ${LISP_CMD} --load bootstrap/build1.lisp
 chmod +x "$tmpfile"
 test -n "$("$tmpfile" version)"
 mv -f "$tmpfile" "$real_target_file"
-if test -z "${NO_PRINT_VERSION:-}"; then
+if test -z "${KILN_NO_PRINT_VERSION:-}"; then
     # real_target_file may be a relative path.
     PATH=$(pwd):$PATH "${real_target_file}" version
 fi

dispatch.lisp

@@ -10,6 +10,7 @@
   (:import-from :kiln/user)
   (:import-from :uiop)
   (:export
+   :*entry-point*
    :dispatch
    :exec
    :invoke-entry-point

flags.lisp

@@ -1,6 +1,16 @@
 (defpackage :kiln/flags
   (:use :cl :serapeum :alexandria)
   (:export
+   :+kiln-debug+
+   :+kiln-heap-size+
+   :+kiln-lisp+
+   :+kiln-no-print-version+
+   :+kiln-stack-size+
+   :+kiln-path-systems+
+   :+kiln-quicklisp+
+   :+kiln-target-file+
+   :+kiln-target-system+
+   :+kiln-tolerant+
    :*flags*
    :dbg?
    :dbg
@@ -16,6 +26,17 @@
 
 (defvar *exit-code* 0)
 
+(def +kiln-debug+ "KILN_DEBUG")
+(def +kiln-heap-size+ "KILN_HEAP_SIZE")
+(def +kiln-lisp+ "KILN_LISP")
+(def +kiln-no-print-version+ "KILN_NO_PRINT_VERSION")
+(def +kiln-stack-size+ "KILN_STACK_SIZE")
+(def +kiln-path-systems+ "KILN_PATH_SYSTEMS")
+(def +kiln-quicklisp+ "KILN_QUICKLISP")
+(def +kiln-target-file+ "KILN_TARGET_FILE")
+(def +kiln-target-system+ "KILN_TARGET_SYSTEM")
+(def +kiln-tolerant+ "KILN_TOLERANT")
+
 (defplace exit-code ()
   *exit-code*)
 

image.lisp

@@ -6,12 +6,13 @@
   (:local-nicknames (:bt :bordeaux-threads))
   (:shadowing-import-from :closer-mop :ensure-finalized)
   (:import-from :cffi)
-  (:import-from :kiln/dispatch)
+  (:import-from :kiln/dispatch :*entry-point*)
+  (:import-from :kiln/flags :dbg :+kiln-target-system+)
   (:import-from :kiln/script-cache :populate-script-cache)
   (:import-from :kiln/script-cache :populate-script-cache)
   (:import-from :kiln/utils :setpgrp)
   (:export
-    :load-all-script-systems))
+   :load-all-script-systems))
 (in-package :kiln/image)
 
 (let (lib-names)
@@ -33,6 +34,10 @@
                        script-systems
                        :test #'equal)))
 
+(defun mark-all-systems-immutable ()
+  (map nil 'asdf:register-immutable-system
+       (asdf:already-loaded-systems)))
+
 (defun record-builtins ()
   (setf *builtins-by-system*
         (list-all-scripts-by-system)
@@ -54,6 +59,9 @@
       (unless (typep cls 'built-in-class)
         (ensure-finalized cls)))))
 
+(defparameter *target-system*
+  (uiop:getenvp +kiln-target-system+))
+
 (defun kiln-before-dump-image ()
   (setf uiop/image::*lisp-interaction* nil)
   #+sbcl (setf sb-ext:*derive-function-types* t)
@@ -65,14 +73,22 @@
       (record-builtins)
       ;; NB Quicklisp doesn't work if it's called inside of the ASDF
       ;; build-op. So we run it in a separate thread. (Is this still true?)
-      (let* ((subsystems (list-builtin-script-subsystems)))
-        (load-all-script-systems :script-systems subsystems)
-        ;; Mark systems immutable twice: first anything loaded by the
-        ;; package scripts (so the shebang scripts load faster), then
-        ;; again for anything loaded after the shebang scripts.
-        (mark-other-systems-immutable :script-systems subsystems)
-        (populate-script-cache)
-        (mark-other-systems-immutable :script-systems subsystems))
+      (if *target-system*
+          (progn
+            (load-system *target-system*)
+            (mark-all-systems-immutable)
+            (setf *entry-point*
+                  (uiop:ensure-function
+                   (asdf/system:component-entry-point
+                    (asdf:find-system *target-system*)))))
+          (let* ((subsystems (list-builtin-script-subsystems)))
+            (load-all-script-systems :script-systems subsystems)
+            ;; Mark systems immutable twice: first anything loaded by the
+            ;; package scripts (so the shebang scripts load faster), then
+            ;; again for anything loaded after the shebang scripts.
+            (mark-other-systems-immutable :script-systems subsystems)
+            (populate-script-cache)
+            (mark-other-systems-immutable :script-systems subsystems)))
       (finalize-all-classes)
       (asdf:clear-configuration)
       (unload-all-foreign-libraries))))
@@ -83,12 +99,12 @@
 #+sbcl
 (defvar *sbcl-home* (sb-int:sbcl-homedir-pathname))
 
-
 (defun kiln-after-restore-image ()
   #+sbcl (sb-ext:disable-debugger)
   ;; TODO Would it be better to preload them all?
-  #+sbcl (setf sb-sys::*sbcl-homedir-pathname* *sbcl-home*)
-  #+sbcl (setf sb-ext:*derive-function-types* nil)
+  (unless *target-system*
+    #+sbcl (setf sb-sys::*sbcl-homedir-pathname* *sbcl-home*)
+    #+sbcl (setf sb-ext:*derive-function-types* nil))
   (setf uiop/image::*lisp-interaction* nil)
   (setpgrp)
   (reload-all-foreign-libraries))

path.lisp

@@ -1,5 +1,6 @@
 (defpackage :kiln/path
   (:use :cl :alexandria :serapeum :kiln/stamp)
+  (:import-from :kiln/flags :+kiln-path-systems+)
   (:import-from :uiop
    :file-exists-p :getenv :getenvp :parse-unix-namestring)
   (:import-from :trivia :match)
@@ -56,7 +57,7 @@
 (-> scripts-path () path-list)
 (defun scripts-path ()
   (append *local-scripts-path*
-          (when-let (env (getenvp "KILN_PATH_SYSTEMS"))
+          (when-let (env (getenvp +kiln-path-systems+))
             (split-sequence-if (op (find _  ",;:"))
                                env
                                :remove-empty-subseqs t))

scripts/rebuild.lisp

@@ -16,7 +16,7 @@
     :string
     :description "Lisp implementation"
     :long-name "lisp"
-    :env-vars '("KILN_LISP")
+    :env-vars (list +kiln-lisp+)
     :key :lisp)
    (cli:make-option
     :string
@@ -27,6 +27,7 @@
     :string
     :description "Executable to generate"
     :long-name "target-file"
+    :short-name #\o
     :key :target-file)
    (cli:make-option
     :flag
@@ -39,28 +40,28 @@
     :long-name "heap-size"
     :description "Lisp heap size (MB)"
     :initial-value nil
-    :env-vars '("KILN_HEAP_SIZE")
+    :env-vars (list +kiln-heap-size+)
     :key :heap-size)
    (cli:make-option
     :integer
     :long-name "stack-size"
     :description "Lisp stack size (MB)"
     :initial-value nil
-    :env-vars '("KILN_STACK_SIZE")
+    :env-vars (list +kiln-stack-size+)
     :key :stack-size)
    (cli:make-option
     :flag
     :description "Use Quicklisp"
     :long-name "quicklisp"
     :initial-value :false
-    :env-vars '("KILN_QUICKLISP")
+    :env-vars (list +kiln-quicklisp+)
     :key :quicklisp)
    (cli:make-option
     :flag
     :description "Skip systems that fail to compile"
     :long-name "tolerant"
     :initial-value :false
-    :env-vars '("KILN_TOLERANT")
+    :env-vars (list +kiln-tolerant+)
     :key :tolerant)))
 
 (def command
@@ -75,28 +76,28 @@
             (cli:getopt opts :target-file))
     (force-output *error-output*)
     (when-let (lisp (cli:getopt opts :lisp))
-      (setf (getenv "KILN_LISP") lisp))
+      (setf (getenv +kiln-lisp+) lisp))
     (when-let (target-system (cli:getopt opts :target-system))
-      (setf (getenv "KILN_TARGET_SYSTEM") target-system))
+      (setf (getenv +kiln-target-system+) target-system))
     (when-let (target-file (cli:getopt opts :target-file))
-      (setf (getenv "KILN_TARGET_FILE") target-file))
-    (when (cli:getopt opts :no-version)
-      (setf (getenv "NO_PRINT_VERSION") "1"))
+      (setf (getenv +kiln-target-file+) target-file))
+    (when (or (cli:getopt opts :no-version)
+              (cli:getopt opts :target-system))
+      (setf (getenv +kiln-no-print-version+) "1"))
     (when-let (heap-size (cli:getopt opts :heap-size))
-      (setf (getenv "KILN_HEAP_SIZE")
+      (setf (getenv +kiln-heap-size+)
             (princ-to-string heap-size)))
     (when-let (stack-size (cli:getopt opts :stack-size))
-      (setf (getenv "KILN_STACK_SIZE")
+      (setf (getenv +kiln-stack-size+)
             (princ-to-string stack-size)))
     (when (cli:getopt opts :quicklisp)
-      (setf (getenv "KILN_QUICKLISP")
+      (setf (getenv +kiln-quicklisp+)
             (if (find-package :ql)
                 (asdf:system-relative-pathname "quicklisp"
                                                "../setup.lisp")
                 (error "Quicklisp requested but not available"))))
     (when (cli:getopt opts :tolerant)
-      (setf (getenv "KILN_TOLERANT") "1"))
-
+      (setf (getenv +kiln-tolerant+) "1"))
     (let ((path (asdf:system-relative-pathname "kiln" "")))
       (uiop:chdir (namestring path))
       (exec "sh build.sh"))))

scripts/self-test.lisp

@@ -220,6 +220,17 @@ This is useful when we need to test the exact output."
     (is (equal (fmt "Before exec~%Unwinding happened~%exec happened")
                result))))
 
+(5am:test entry-point
+  (with-templated-test-system (:name "kiln-entry-point-system"
+                               :path path
+                               :kiln-path nil)
+    (uiop:with-temporary-file (:pathname tmp)
+      (cmd *self*
+           "rebuild --target-file" tmp
+           "--target-system kiln-entry-point-system")
+      (is (uiop:file-exists-p tmp))
+      (is (equal "Hello, world" ($cmd tmp))))))
+
 (defun main (args)
   (destructuring-bind (&optional (test 'test)) args
     (when (stringp test)

test/kiln-entry-point-system/kiln-entry-point-system-dot-asd

@@ -1,3 +1,5 @@
+;;; -*- mode: lisp -*-
 (defsystem "kiln-entry-point-system"
   :build-operation "asdf:program-op"
-  :entry-point "kiln-entry-point-system:entry-point")
+  :entry-point "kiln-entry-point-system:entry-point"
+  :components ((:file "kiln-entry-point-system")))

test/kiln-entry-point-system/kiln-entry-point-system-dot-lisp

@@ -1,6 +1,8 @@
+;;; -*- mode: lisp -*-
 (defpackage :kiln-entry-point-system
-  (:use :cl))
+  (:use :cl)
+  (:export :entry-point))
 (in-package :kiln-entry-point-system)
 
 (defun entry-point ()
-  (format *error-output* "Hello, world"))
+  (format t "Hello, world~%"))

test/other-test-system/other-test-system-dot-lisp

@@ -1 +1,2 @@
+;;; -*- mode: lisp -*-
 (defpackage :other-test-system)