Rework VM approach to shuffling unknown numbers of args

* libguile/vm-engine.c (shuffle-down, expand-apply-argument): New
  instructions.
  (tail-call, tail-call-label, return-values): Don't reset the frame.
  The compiler should reset the frame appropriately.
  (tail-call/shuffle, tail-apply): Remove unused instructions.
* libguile/vm.c (vm_builtin_apply_code): Use new shuffle-down and
  expand-apply-argument opcodes.
  (vm_builtin_call_with_values_code): Replace tail-call/shuffle with
  shuffle-down then tail-call.
* libguile/jit.c (compile_shuffle_down, compile_expand_apply_argument):
  Add compiler stubs
  (COMPILE_X8_F12_F12): New definition.
  (compile_tail_call_shuffle, compile_tail_apply): Remove unused
  compilers.
* module/language/cps/compile-bytecode.scm (compile-function): Emit
  reset-frame before tail calls and returns.
* module/system/vm/assembler.scm (system): Remove unbound "emit-return"
  export.
* module/system/vm/disassembler.scm (code-annotation)
  (instruction-has-fallthrough?, define-stack-effect-parser): Adapt for
  opcode changes.

1 files changed, 9 insertions, 18 deletions

diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm
index f46b160c6..83499333c 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -235,14 +235,8 @@ address of that offset."
      (list "~a slot~:p" nlocals))
     (('reset-frame nlocals)
      (list "~a slot~:p" nlocals))
-    (('return-values nlocals)
-     (if (zero? nlocals)
-         (list "all values")
-         (list "~a value~:p" (1- nlocals))))
     (('bind-rest dst)
      (list "~a slot~:p" (1+ dst)))
-    (('tail-call nargs proc)
-     (list "~a arg~:p" nargs))
     (('make-closure dst target nfree)
      (let* ((addr (u32-offset->addr (+ offset target) context))
             (pdi (find-program-debug-info addr context))
@@ -264,7 +258,7 @@ address of that offset."
                       "anonymous procedure")))
        (push-addr! addr name)
        (list "~A at #x~X" name addr)))
-    (('tail-call-label nlocals target)
+    (('tail-call-label target)
      (let* ((addr (u32-offset->addr (+ offset target) context))
             (pdi (find-program-debug-info addr context))
             (name (or (and pdi (program-debug-info-name pdi))
@@ -507,17 +501,10 @@ address of that offset."
 (define (instruction-has-fallthrough? code pos)
   (define non-fallthrough-set
     (static-opcode-set halt
-                       ;; FIXME: add throw, throw/value,
-                       ;; throw/value+data.  Currently control flow
-                       ;; nominally continues; we don't add these ops to
-                       ;; the non-fallthrough-set currently to allow the
-                       ;; frame parser to be able to compute the stack
-                       ;; size for following code.
                        throw throw/value throw/value+data
-                       tail-call tail-call-label tail-call/shuffle
+                       tail-call tail-call-label
                        return-values
                        subr-call foreign-call continuation-call
-                       tail-apply
                        j))
   (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
     (not (bitvector-ref non-fallthrough-set opcode))))
@@ -582,10 +569,14 @@ address of that offset."
                                   #xfff))
                    (nlocals (ash (bytevector-u32-native-ref code pos) -20)))
                (+ nargs nlocals))))
-        ((call call-label)
-         #'(lambda (code pos size) #f))
-        ((tail-call tail-call-label tail-call/shuffle tail-apply)
+        ((call call-label tail-call tail-call-label expand-apply-argument)
          #'(lambda (code pos size) #f))
+        ((shuffle-down)
+         #'(lambda (code pos size)
+             (let ((from (logand (ash (bytevector-u32-native-ref code pos) -8)
+                                 #xfff))
+                   (to (ash (bytevector-u32-native-ref code pos) -20)))
+               (and size (- size (- from to))))))
         (else
          #f)))
     (syntax-case x ()