New macro: load-time.

This is similar to the ANSI CL load-time-value.

* eval.c (load_time_s, load_time_lit_s): New symbol variables.
(op_load_time_lit, me_load_time): New static functions.
(eval_init): Intern load-time symbol and sys:load-time-lit.
Register the sys:load-time-lit special operator and load-time
macro.

* share/txr/stdlib/asm.tl (assembler parse-args): We must
now allow the d registers to be the targets of a mov
instruction, because load-time depends on being able to mutate
the data vector, in order to turn the result of a calculation
into a de facto literal.

* share/txr/stdlib/compiler.tl (compiler): New member,
lt-frags.
(compile-in-toplevel): New macro.
(compiler alloc-dreg): New method.
(compiler compile): Handle sys:load-time-lit special form
via comp-load-time-lit method.
(compiler comp-load-time-lit): New method.
(usr:compile-toplevel): Prepend the load-time assembly code
fragments to the compiled assembly code.

* vm.c (vm_set, vm_sm_set): Do not reject an attempt to modify
the static data, since load-time now generates mov
instructions targetting the d registers.

* txr.1: Document load-time.

2 files changed, 46 insertions, 4 deletions

diff --git a/share/txr/stdlib/asm.tl b/share/txr/stdlib/asm.tl
index 990c126f..805de9e9 100644
--- a/share/txr/stdlib/asm.tl
+++ b/share/txr/stdlib/asm.tl
@@ -164,9 +164,7 @@
                 oc.(synerr "argument ~a of ~s invalid; ~a expected"
                            n syntax [me.operand-name type]))
               (when (and (member type '(d ds))
-                         (or (zerop parg) (<= %lev-size%
-                                              parg
-                                              (+ %lev-size% %max-lev-idx%))))
+                         (or (zerop parg)))
                 oc.(synerr "argument ~a of ~s cannot be destination"
                            n syntax))
               (when (and (member type '(rs ds))
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index dc222d54..a2adfa1e 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -116,8 +116,27 @@
     (data (hash :eql-based))
     (fidx (hash :eql-based))
     (ftab (hash :eql-based))
+    lt-frags
     last-form))
 
+(defmacro compile-in-toplevel (comp . body)
+  (with-gensyms (comp-var saved-tregs saved-treg-cntr saved-nlev)
+    ^(let* ((,comp-var ,comp)
+            (,saved-tregs (qref ,comp-var tregs))
+            (,saved-treg-cntr (qref ,comp-var treg-cntr))
+            (,saved-nlev (qref ,comp-var nlev)))
+       (unwind-protect
+         (progn
+           (set (qref ,comp-var tregs) nil
+                (qref ,comp-var treg-cntr) 2
+                (qref ,comp-var nlev) 2)
+           (prog1
+             (progn ,*body)
+             (qref ,comp-var (check-treg-leak))))
+         (set (qref ,comp-var tregs) ,saved-tregs
+              (qref ,comp-var treg-cntr) ,saved-treg-cntr
+              (qref ,comp-var nlev) ,saved-nlev)))))
+
 (compile-only
   (defstruct param-parser-base nil
     syntax form
@@ -178,6 +197,13 @@
       (set [me.dreg atom] dreg)))
     (t (compile-error me.last-form "code too complex: too many literals"))))
 
+(defmeth compiler alloc-dreg (me)
+  (if (< me.dreg-cntr %lev-size%)
+    (let ((dreg ^(d ,(pinc me.dreg-cntr))))
+      (set [me.data (cadr dreg)] nil)
+      dreg)
+    (compile-error me.last-form "code too complex: too many literals")))
+
 (defmeth compiler get-fidx (me atom)
   (iflet ((fidx [me.fidx atom]))
     fidx
@@ -276,6 +302,7 @@
             (sys:upenv me.(compile oreg env.up (cadr form)))
             (sys:dvbind me.(compile oreg env (caddr form)))
             (sys:with-dyn-rebinds me.(comp-progn oreg env (cddr form)))
+            (sys:load-time-lit me.(comp-load-time-lit oreg env form))
             ((macrolet symacrolet macro-time)
              (compile-error form "unexpanded ~s encountered" sym))
             ((sys:var sys:expr)
@@ -1079,6 +1106,23 @@
                    (end ,bfrag.oreg))
                  bfrag.fvars bfrag.ffuns)))))
 
+(defmeth compiler comp-load-time-lit (me oreg env form)
+  (mac-param-bind form (op loaded-p exp) form
+    (if loaded-p
+      me.(compile oreg env ^(quote ,exp))
+      (compile-in-toplevel me
+        (let* ((oreg me.(alloc-treg))
+               (dreg me.(alloc-dreg))
+               (exp me.(compile oreg (new env co me) exp))
+               (lt-frag (new (frag dreg
+                                   ^(,*exp.code
+                                     (mov ,dreg ,exp.oreg))
+                                   exp.fvars
+                                   exp.ffuns))))
+          me.(free-treg oreg)
+          (push lt-frag me.lt-frags)
+          (new (frag dreg nil)))))))
+
 (defun maybe-mov (to-reg from-reg)
   (if (nequal to-reg from-reg)
     ^((mov ,to-reg ,from-reg))))
@@ -1399,7 +1443,7 @@
            (frag co.(compile oreg (new env co co) xexp)))
       co.(free-treg oreg)
       co.(check-treg-leak)
-      as.(asm ^(,*frag.code (end ,frag.oreg)))
+      as.(asm ^(,*(mappend .code (nreverse co.lt-frags)) ,*frag.code (end ,frag.oreg)))
       (vm-make-desc co.nlev (succ as.max-treg) as.buf co.(get-datavec) co.(get-funvec)))))
 
 (defvarl %file-suff-rx% #/[.][^\\\/.]+/)