RTL: Compile prompts

* libguile/vm-engine.c (prompt): Adapt to explicitly set the saved SP so
  we know how many incoming values the handler will receive, and to make
  escape-only? a flag.

* module/language/cps/compile-rtl.scm (emit-rtl-sequence): $prompt
  should only be found in a "seq" context, as it just pushes on a prompt
  and doesn't bind any values.  On the other hand it should emit
  appropriate code for the handler to bind its values, so do that.

* module/language/cps/slot-allocation.scm ($cont-allocation): Add a note
  that proc-slot is used by prompts as well.
  (allocate-slots): Compute the allocation of a prompt handler's args.

* module/language/tree-il/compile-cps.scm (convert): Use "unwind"
  instead of the nonexistent "pop-prompt".

* module/system/vm/disassembler.scm (code-annotation): Adapt to change
  in prompt VM op.

diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 6c1318f..2723702 100644 (file)
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -2266,35 +2266,36 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
    * The dynamic environment
    */
 
-  /* prompt tag:24 flags:8 handler-offset:24
+  /* prompt tag:24 escape-only?:1 _:7 proc-slot:24 _:8 handler-offset:24
    *
    * Push a new prompt on the dynamic stack, with a tag from TAG and a
    * handler at HANDLER-OFFSET words from the current IP.  The handler
-   * will expect a multiple-value return.
+   * will expect a multiple-value return as if from a call with the
+   * procedure at PROC-SLOT.
    */
-  VM_DEFINE_OP (58, prompt, "prompt", OP2 (U8_U24, U8_L24))
-#if 0
+  VM_DEFINE_OP (58, prompt, "prompt", OP3 (U8_U24, B1_X7_U24, X8_L24))
     {
-      scm_t_uint32 tag;
+      scm_t_uint32 tag, proc_slot;
       scm_t_int32 offset;
       scm_t_uint8 escape_only_p;
       scm_t_dynstack_prompt_flags flags;
 
       SCM_UNPACK_RTL_24 (op, tag);
-      escape_only_p = ip[1] & 0xff;
-      offset = ip[1];
+      escape_only_p = ip[1] & 0x1;
+      SCM_UNPACK_RTL_24 (ip[1], proc_slot);
+      offset = ip[2];
       offset >>= 8; /* Sign extension */
   
       /* Push the prompt onto the dynamic stack. */
       flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0;
       scm_dynstack_push_prompt (&current_thread->dynstack, flags,
                                 LOCAL_REF (tag),
-                                fp, vp->sp, ip + offset, &registers);
-      NEXT (2);
+                                fp,
+                                &LOCAL_REF (proc_slot),
+                                (scm_t_uint8 *)(ip + offset),
+                                &registers);
+      NEXT (3);
     }
-#else
-  abort();
-#endif
 
   /* wind winder:12 unwinder:12
    *

diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm
index 85e9fec..0303d61 100644 (file)
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -190,9 +190,7 @@
              (emit-text asm `((,inst ,dst ,@(map slot args))))))
           (($ $values (arg))
            (or (maybe-load-constant dst arg)
-               (maybe-mov dst (slot arg))))
-          (($ $prompt escape? tag handler)
-           (emit-prompt asm escape? tag handler)))
+               (maybe-mov dst (slot arg)))))
         (maybe-jump k)))
 
     (define (emit-vals syms)
@@ -224,9 +222,28 @@
          (emit-set-cdr! asm (slot pair) (slot value)))
         (($ $primcall 'define! (sym value))
          (emit-define asm (slot sym) (slot value)))
+        (($ $primcall 'unwind ())
+         (emit-unwind asm))
         (($ $primcall name args)
          (error "unhandled primcall in seq context" name))
-        (($ $values ()) #f))
+        (($ $values ()) #f)
+        (($ $prompt escape? tag handler)
+         (match (lookup-cont handler cont-table)
+           (($ $ktrunc ($ $arity req () rest () #f) khandler-body)
+            (let ((receive-args (gensym "handler"))
+                  (nreq (length req))
+                  (proc-slot (lookup-call-proc-slot label allocation)))
+              (emit-prompt asm (slot tag) escape? proc-slot receive-args)
+              (emit-br asm k)
+              (emit-label asm receive-args)
+              (emit-receive-values asm proc-slot (->bool rest) nreq)
+              (when rest
+                (emit-bind-rest asm (+ proc-slot 1 nreq)))
+              (for-each (match-lambda
+                         ((src . dst) (emit-mov asm dst src)))
+                        (lookup-parallel-moves handler allocation))
+              (emit-reset-frame asm nlocals)
+              (emit-br asm khandler-body))))))
       (maybe-jump k))
 
     (define (emit-test kt kf)

diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index b446d9e..e4e85ec 100644 (file)
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -73,6 +73,10 @@
   ;; Currently calls are allocated in the caller frame, above all locals
   ;; that are live at the time of the call.  Therefore there is no
   ;; parallel move problem.  We could be more clever here.
+  ;;
+  ;; $prompt expressions also use this call slot to indicate where the
+  ;; handler's arguments are expected, but without reserving space for a
+  ;; frame or for the procedure slot.
   (call-proc-slot cont-call-proc-slot)
 
   ;; Tail calls, multiple-value returns, and jumps to continuations with
@@ -223,6 +227,9 @@ are comparable with eqv?.  A tmp slot may be used."
   (define (compute-call-proc-slot live-set nlocals)
     (+ 3 (find-first-trailing-zero (car live-set) nlocals)))
 
+  (define (compute-prompt-handler-proc-slot live-set nlocals)
+    (1- (find-first-trailing-zero (car live-set) nlocals)))
+
   (define dfg (compute-dfg fun #:global? #f))
   (define allocation (make-hash-table))
              
@@ -262,6 +269,16 @@ are comparable with eqv?.  A tmp slot may be used."
          (set-allocation-dead! allocation (cons k dead))
          (remove-live-variable sym slot live-set))))
 
+    (define (allocate-prompt-handler! k live-set)
+      (let ((proc-slot (compute-prompt-handler-proc-slot live-set nlocals)))
+        (hashq-set! allocation k
+                    (make-cont-allocation
+                     proc-slot
+                     (match (hashq-ref allocation k)
+                       (($ $cont-allocation #f moves) moves)
+                       (#f #f))))
+        live-set))
+
     (define (allocate-frame! k nargs live-set)
       (let ((proc-slot (compute-call-proc-slot live-set nlocals)))
         (set! nlocals (max nlocals (+ proc-slot 1 nargs)))
@@ -403,6 +420,18 @@ are comparable with eqv?.  A tmp slot may be used."
                            (compute-dst-slots))))
 
         (($ $prompt escape? tag handler)
+         (match (lookup-cont handler (dfg-cont-table dfg))
+           (($ $ktrunc arity kargs)
+            (let* ((live-set (allocate-prompt-handler! label live-set))
+                   (proc-slot (lookup-call-proc-slot label allocation))
+                   (dst-syms (lookup-bound-syms kargs dfg))
+                   (nvals (length dst-syms))
+                   (src-slots (map (cut + proc-slot 1 <>) (iota nvals)))
+                   (live-set* (fold (cut allocate! <> kargs <> <>)
+                                    live-set dst-syms src-slots))
+                   (dst-slots (map (cut lookup-slot <> allocation)
+                                   dst-syms)))
+              (parallel-move! handler src-slots live-set live-set* dst-slots))))
          (use tag live-set))
 
         (_ live-set)))

diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 836f10e..707e08b 100644 (file)
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -391,7 +391,7 @@
                                              ($continue kprim
                                                ($prim 'values))))))
                                   ($continue kret
-                                    ($primcall 'pop-prompt ())))))
+                                    ($primcall 'unwind ())))))
                         (krest src ($ktrunc '() 'rest kpop)))
                  ,(if escape-only?
                       (build-cps-term

diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm
index 4917743..09ca337 100644 (file)
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -217,7 +217,7 @@ address of that offset."
           'br-if-char 'br-if-tc7 'br-if-eq 'br-if-eqv 'br-if-equal
           'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->=) _ ... target)
      (list "-> ~A" (vector-ref labels (- (+ offset target) start))))
-    (('prompt tag flags handler)
+    (('prompt tag escape-only? proc-slot handler)
      ;; The H is for handler.
      (list "H -> ~A" (vector-ref labels (- (+ offset handler) start))))
     (((or 'make-short-immediate 'make-long-immediate) _ imm)