compiler: new dump-compiled-objects function.

* lisplib.c (compiler_set_entries): Register
dump-compiled-objects for auto-loading.

* share/txr/stdlib/compiler.tl (usr:dmp-to-tlo): New
function.
(compile-file): Code to be shared with dump-compiled-objects
moved into dump-to-tlo function.
(usr:dump-compiled-objects): New function.

* txr.1: Documented.

3 files changed, 124 insertions, 7 deletions

diff --git a/lisplib.c b/lisplib.c
index a8a996b6..902d847f 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -705,7 +705,7 @@ static val compiler_set_entries(val dlt, val fun)
   };
   val name[] = {
     lit("compile-toplevel"), lit("compile-file"), lit("compile"),
-    lit("with-compilation-unit"),
+    lit("with-compilation-unit"), lit("dump-compiled-objects"),
     nil
   };
 
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index f2c64f41..da49c873 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -1657,6 +1657,14 @@
            (release-deferred-warnings)
            (compiler-emit-warnings))))))
 
+(defun usr:dump-to-tlo (out-stream out)
+  (let* ((*print-circle* t)
+         (*package* (sys:make-anon-package))
+         (out-forms (split* out.(get) (op where (op eq :fence)))))
+    (prinl %tlo-ver% out-stream)
+    [mapdo (op prinl @1 out-stream) out-forms]
+    (delete-package *package*)))
+
 (defun usr:compile-file (in-path : out-path)
   (let ((streams (open-compile-streams in-path out-path))
         (err-ret (gensym))
@@ -1696,22 +1704,38 @@
                                   out.(add flat-vd)
                                   (when fence
                                     out.(add :fence)))))))))))
-          (prinl %tlo-ver% out-stream)
           (unwind-protect
             (whilet ((obj (read in-stream *stderr* err-ret))
                      ((neq obj err-ret)))
               (compile-form obj))
-            (let* ((*print-circle* t)
-                   (*package* (sys:make-anon-package))
-                   (out-forms (split* out.(get) (op where (op eq :fence)))))
-              [mapdo (op prinl @1 out-stream) out-forms]
-              (delete-package *package*)))
+            (dump-to-tlo out-stream out))
 
           (let ((parser (sys:get-parser in-stream)))
             (when (> (sys:parser-errors parser) 0)
               (error "~s: compilation of ~s failed" 'compile-file
                      (stream-get-prop in-stream :name)))))))))
 
+(defun usr:dump-compiled-objects (out-stream . compiled-objs)
+  (symacrolet ((self 'dump-compiled-object))
+    (let ((out (new list-builder)))
+      (flet ((vm-from-fun (fun)
+               (unless (vm-fun-p fun)
+                 (error "~s: not a vm function: ~s" self fun))
+               (sys:vm-closure-desc (func-get-env fun))))
+        (each ((obj compiled-objs))
+          (let* ((vm-desc (typecase obj
+                            (vm-desc obj)
+                            (fun (vm-from-fun obj))
+                            (t (iflet ((fun (symbol-function obj)))
+                                 (vm-from-fun fun)
+                                 (error "~s: not a compiled object: ~s"
+                                        self obj)))))
+                 (symvec (sys:vm-desc-symvec vm-desc)))
+            out.(add (list-from-vm-desc vm-desc))
+            (when (isec symvec %package-manip%)
+              out.(add :fence)))))
+      (dump-to-tlo out-stream out))))
+
 (defun sys:env-to-let (env form)
   (when env
     (let ((vb (env-vbindings env))
diff --git a/txr.1 b/txr.1
index 00eaabec..cdcf22d6 100644
--- a/txr.1
+++ b/txr.1
@@ -64079,6 +64079,99 @@ The
 .code disassemble
 function returns its argument.
 
+.coNP Function @ dump-compiled-objects
+.synb
+.mets (dump-compiled-objects < stream << object *)
+.syne
+.desc
+The
+.code dump-compiled-objects
+function writes compiled objects into
+.meta stream
+in the same format as the
+.code compile-file
+function.
+
+Unlike under
+.codn compile-file ,
+the output is written into an arbitrary stream rather than a named file.
+The objects aren't specified by the to-be-compiled syntax processed from a
+source file, but rather as zero or more arguments which specify objects that
+are already compiled.
+
+Each
+.meta object
+must be be one of three kinds of values:
+.RS
+.IP 1.
+a virtual machine description object returned by
+.code compile-toplevel
+function; or
+.IP 2.
+a compiled function object, satisfying the function
+.codn vm-fun-p ;
+or else
+.IP 3.
+the name of a compiled function object, which may take any of the
+forms suitable as arguments to the
+.code symbol-function
+function.
+.RE
+.IP
+First,
+.code dump-compiled-objects
+writes some preamble information into
+.metn stream .
+Then, for each
+.meta object
+that is not already a virtual machine description, its corresponding
+virtual machine description is retrieved. The virtual machine description
+is converted into the externalized format required for the object format
+and that externalized format is written into
+.metn stream .
+The
+.code object
+argument are thus processed in left-to-right order.
+
+If exactly one call to
+.code dump-compiled-objects
+is used to populate an initially empty file, and no other data are
+written into the file, then that file is a valid compiled file.
+If that file is processed by
+.code load-file
+then each of the externalized forms is converted to a virtual machine
+description and executed.
+
+Note that virtual machine descriptions are not functions. A function's
+virtual machine description is the compiled version of the top-level form
+whose evaluation produced that function.
+
+For example, if the following top-level form is compiled and executed,
+two functions are defined:
+
+.cblk
+  (let ()
+    (defun a ())
+    (defun b ()))
+.cble
+
+Then, the following three expressions all have the same effect on
+stream
+.codn s :
+
+.cblk
+  (dump-compiled-objects s 'a)
+  (dump-compiled-objects s 'b)
+.cble
+
+Whether the
+.code a
+or
+.code b
+symbol is used to specify the object to be dumped, the same virtual machine
+description is externalized and deposited into the stream. That machine
+description, when loaded and executed, defines two functions.
+
 .SH* INTERACTIVE LISTENER
 
 .SS* Overview