WIP Allow building a executable with Kiln

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,16 @@
                         "2.2.6")
                        -7
                        1)))
-(defparameter *target-system* (uiop:getenv "KILN_TARGET_SYSTEM"))
-(assert (stringp *target-system*))
-(assert (not (= 0 (length *target-system*))))
+(let ((target-system (uiop:getenvp "KILN_TARGET_SYSTEM")))
+  (when target-system
+    (setf (uiop:getenv "KILN_ENTRY_POINT")
+          (asdf/system:component-entry-point
+           (asdf:find-system 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,12 @@ set -eu
 : "${KILN_LISP:=sbcl}"
 : "${KILN_HEAP_SIZE:=32768}"
 : "${KILN_STACK_SIZE:=}"
+: "${KILN_TARGET_SYSTEM:=}"
 
 if test -n "$KILN_DEBUG"; then
     set -x
 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"}"
 

dispatch.lisp

@@ -29,7 +29,10 @@
 (deftype args-state ()
   '(member :flags :script-name :script-args))
 
-(defparameter *entry-point* 'dispatch/argv)
+(defparameter *entry-point*
+  (if-let (entry-point (uiop:getenvp "KILN_ENTRY_POINT"))
+    (uiop:ensure-function entry-point)
+    'dispatch/argv))
 
 (-> parse-args (list) (values list (or null string) list))
 (defun parse-args (args)

image.lisp

@@ -62,16 +62,19 @@
                      (print e uiop:*stderr*)
                      (uiop:print-backtrace e :stream uiop:*stderr*))))
     (with-user-abort
-      (record-builtins)
+        (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)
+      (let* ((subsystems (list-builtin-script-subsystems))
+             (entry-point? (uiop:getenvp "KILN_ENTRY_POINT")))
+        (unless entry-point?
+          (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)
+        (unless entry-point?
+          (populate-script-cache))
         (mark-other-systems-immutable :script-systems subsystems))
       (finalize-all-classes)
       (asdf:clear-configuration)
@@ -87,8 +90,9 @@
 (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 (uiop:getenvp "KILN_ENTRY_POINT")
+    #+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))

scripts/rebuild.lisp

@@ -61,7 +61,13 @@
     :long-name "tolerant"
     :initial-value :false
     :env-vars '("KILN_TOLERANT")
-    :key :tolerant)))
+    :key :tolerant)
+   (cli:make-option
+    :string
+    :description "Use this system's entry point"
+    :long-name "entry-point-system"
+    :env-vars '("KILN_ENTRY_POINT")
+    :key :entry-point-system)))
 
 (def command
   (cli:make-command
@@ -80,7 +86,8 @@
       (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)
+    (when (or (cli:getopt opts :no-version)
+              (cli:getopt opts :entry-point-system))
       (setf (getenv "NO_PRINT_VERSION") "1"))
     (when-let (heap-size (cli:getopt opts :heap-size))
       (setf (getenv "KILN_HEAP_SIZE")
@@ -96,7 +103,8 @@
                 (error "Quicklisp requested but not available"))))
     (when (cli:getopt opts :tolerant)
       (setf (getenv "KILN_TOLERANT") "1"))
-
+    (when-let (entry-point-system (cli:getopt opts :entry-point-system))
+      (setf (getenv "KILN_ENTRY_POINT") entry-point-system))
     (let ((path (asdf:system-relative-pathname "kiln" "")))
       (uiop:chdir (namestring path))
       (exec "sh build.sh"))))

scripts/self-test.lisp

@@ -220,6 +220,18 @@ 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*
+           "--target-file"
+           tmp
+           "--entry-point-system kiln-entry-point-system")
+      (is (file-exists-p tmp))
+      (is (equal "Hello, world" ($cmd tmp))))))
+
 (defun main (args)
   (destructuring-bind (&optional (test 'test)) args
     (when (stringp test)