[Guile-commits] 06/08: Rework VM approach to shuffling unknown numbers of args

[Andy Wingo]

wingo pushed a commit to branch lightning
in repository guile.

commit c2a8224a63da432c82f24a76c008e4cfe9cba25b
Author: Andy Wingo <address@hidden>
Date:   Thu Jul 19 10:56:44 2018 +0200

    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.
---
 libguile/jit.c                           |  31 ++++--
 libguile/vm-engine.c                     | 171 +++++++++++--------------------
 libguile/vm.c                            |   9 +-
 module/language/cps/compile-bytecode.scm |  12 ++-
 module/system/vm/assembler.scm           |   3 +-
 module/system/vm/disassembler.scm        |  27 ++---
 6 files changed, 104 insertions(+), 149 deletions(-)

diff --git a/libguile/jit.c b/libguile/jit.c
index 3cb3ddd..04e2810 100644
--- a/libguile/jit.c
+++ b/libguile/jit.c
@@ -61,32 +61,32 @@ compile_call_label (scm_jit_state *j, uint32_t a, uint32_t 
b, int32_t offset)
 }
 
 static void
-compile_tail_call (scm_jit_state *j, uint32_t a)
+compile_tail_call (scm_jit_state *j)
 {
 }
 
 static void
-compile_tail_call_label (scm_jit_state *j, uint32_t a, int32_t offset)
+compile_tail_call_label (scm_jit_state *j, int32_t offset)
 {
 }
 
 static void
-compile_tail_call_shuffle (scm_jit_state *j, uint32_t a)
+compile_receive (scm_jit_state *j, uint16_t dst, uint16_t a, uint32_t b)
 {
 }
 
 static void
-compile_receive (scm_jit_state *j, uint16_t dst, uint16_t a, uint32_t b)
+compile_receive_values (scm_jit_state *j, uint32_t a, uint8_t b, uint32_t c)
 {
 }
 
 static void
-compile_receive_values (scm_jit_state *j, uint32_t a, uint8_t b, uint32_t c)
+compile_shuffle_down (scm_jit_state *j, uint16_t from, uint16_t to)
 {
 }
 
 static void
-compile_return_values (scm_jit_state *j, uint32_t a)
+compile_return_values (scm_jit_state *j)
 {
 }
 
@@ -111,11 +111,6 @@ compile_compose_continuation (scm_jit_state *j, uint32_t a)
 }
 
 static void
-compile_tail_apply (scm_jit_state *j)
-{
-}
-
-static void
 compile_call_cc (scm_jit_state *j)
 {
 }
@@ -191,6 +186,11 @@ compile_assert_nargs_ee_locals (scm_jit_state *j, uint16_t 
a, uint16_t b)
 }
 
 static void
+compile_expand_apply_argument (scm_jit_state *j)
+{
+}
+
+static void
 compile_bind_kwargs (scm_jit_state *j, uint32_t a, uint8_t b, uint32_t c, 
uint32_t d, int32_t offset)
 {
 }
@@ -917,6 +917,8 @@ compile_f64_set (scm_jit_state *j, uint8_t a, uint8_t b, 
uint8_t c)
   COMPILE_X8_C12_C12 (j, comp)
 #define COMPILE_X8_S12_S12(j, comp)                                     \
   COMPILE_X8_C12_C12 (j, comp)
+#define COMPILE_X8_F12_F12(j, comp)                                     \
+  COMPILE_X8_C12_C12 (j, comp)
 
 #define COMPILE_X8_S12_Z12(j, comp)                                     \
   {                                                                     \
@@ -953,6 +955,13 @@ compile_f64_set (scm_jit_state *j, uint8_t a, uint8_t b, 
uint8_t c)
     j->ip += 2;                                                         \
   }
 
+#define COMPILE_X32__L32(j, comp)                                       \
+  {                                                                     \
+    int32_t a = j->ip[1];                                               \
+    comp (j, a);                                                        \
+    j->ip += 1;                                                         \
+  }
+
 #define COMPILE_X8_C24__L32(j, comp)                                    \
   {                                                                     \
     uint32_t a;                                                         \
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 341a006..383b4f5 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -428,20 +428,14 @@ VM_NAME (scm_thread *thread)
       NEXT (0);
     }
 
-  /* tail-call nlocals:24
+  /* tail-call _:24
    *
-   * Tail-call a procedure.  Requires that the procedure and all of the
-   * arguments have already been shuffled into position.  Will reset the
-   * frame to NLOCALS.
+   * Tail-call the procedure in slot 0 with the arguments in the current
+   * stack frame.  Requires that the procedure and all of the arguments
+   * have already been shuffled into position.
    */
-  VM_DEFINE_OP (3, tail_call, "tail-call", OP1 (X8_C24))
+  VM_DEFINE_OP (3, tail_call, "tail-call", OP1 (X32))
     {
-      uint32_t nlocals;
-      
-      UNPACK_24 (op, nlocals);
-
-      RESET_FRAME (nlocals);
-
       if (SCM_LIKELY (SCM_PROGRAM_P (FP_REF (0))))
         ip = SCM_PROGRAM_CODE (FP_REF (0));
       else
@@ -456,21 +450,17 @@ VM_NAME (scm_thread *thread)
       NEXT (0);
     }
 
-  /* tail-call-label nlocals:24 label:32
+  /* tail-call-label _:24 label:32
    *
    * Tail-call a known procedure.  As call is to call-label, tail-call
    * is to tail-call-label.
    */
-  VM_DEFINE_OP (4, tail_call_label, "tail-call-label", OP2 (X8_C24, L32))
+  VM_DEFINE_OP (4, tail_call_label, "tail-call-label", OP2 (X32, L32))
     {
-      uint32_t nlocals;
       int32_t label;
       
-      UNPACK_24 (op, nlocals);
       label = ip[1];
 
-      RESET_FRAME (nlocals);
-
       ip += label;
 
       APPLY_HOOK ();
@@ -478,39 +468,10 @@ VM_NAME (scm_thread *thread)
       NEXT (0);
     }
 
-  /* tail-call/shuffle from:24
-   *
-   * Tail-call a procedure.  The procedure should already be set to slot
-   * 0.  The rest of the args are taken from the frame, starting at
-   * FROM, shuffled down to start at slot 0.  This is part of the
-   * implementation of the call-with-values builtin.
-   */
-  VM_DEFINE_OP (5, tail_call_shuffle, "tail-call/shuffle", OP1 (X8_F24))
+  VM_DEFINE_OP (5, unused_5, NULL, NOP)
     {
-      uint32_t n, from, nlocals;
-
-      UNPACK_24 (op, from);
-
-      VM_ASSERT (from > 0, abort ());
-      nlocals = FRAME_LOCALS_COUNT ();
-
-      for (n = 0; from + n < nlocals; n++)
-        FP_SET (n + 1, FP_REF (from + n));
-
-      RESET_FRAME (n + 1);
-
-      if (SCM_LIKELY (SCM_PROGRAM_P (FP_REF (0))))
-        ip = SCM_PROGRAM_CODE (FP_REF (0));
-      else
-        {
-          SYNC_IP ();
-          CALL_INTRINSIC (apply_non_program, (thread));
-          CACHE_REGISTER ();
-        }
-
-      APPLY_HOOK ();
-
-      NEXT (0);
+      vm_error_bad_instruction (op);
+      abort (); /* never reached */
     }
 
   /* receive dst:12 proc:12 _:8 nlocals:24
@@ -554,29 +515,36 @@ VM_NAME (scm_thread *thread)
       NEXT (2);
     }
 
-  VM_DEFINE_OP (8, unused_8, NULL, NOP)
+  /* shuffle-down from:12 to:12
+   *
+   * Shuffle down values from FROM to TO, reducing the frame size by
+   * (FROM-TO) slots.  Part of the internal implementation of
+   * call-with-values, values, and apply.
+   */
+  VM_DEFINE_OP (8, shuffle_down, "shuffle-down", OP1 (X8_F12_F12))
     {
-      vm_error_bad_instruction (op);
-      abort (); /* never reached */
+      uint32_t n, from, to, nlocals;
+
+      UNPACK_12_12 (op, from, to);
+
+      VM_ASSERT (from > to, abort ());
+      nlocals = FRAME_LOCALS_COUNT ();
+
+      for (n = 0; from + n < nlocals; n++)
+        FP_SET (to + n, FP_REF (from + n));
+
+      RESET_FRAME (to + n);
+
+      NEXT (1);
     }
 
-  /* return-values nlocals:24
+  /* return-values _:24
    *
-   * Return a number of values from a call frame.  This opcode
-   * corresponds to an application of `values' in tail position.  As
-   * with tail calls, we expect that the values have already been
-   * shuffled down to a contiguous array starting at slot 1.
-   * If NLOCALS is not zero, we also reset the frame to hold NLOCALS
-   * values.
+   * Return all values from a call frame.
    */
-  VM_DEFINE_OP (9, return_values, "return-values", OP1 (X8_C24))
+  VM_DEFINE_OP (9, return_values, "return-values", OP1 (X32))
     {
       union scm_vm_stack_element *old_fp;
-      uint32_t nlocals;
-
-      UNPACK_24 (op, nlocals);
-      if (nlocals)
-        RESET_FRAME (nlocals);
 
       old_fp = VP->fp;
       ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (VP->fp);
@@ -706,51 +674,10 @@ VM_NAME (scm_thread *thread)
       NEXT (0);
     }
 
-  /* tail-apply _:24
-   *
-   * Tail-apply the procedure in local slot 1 to the rest of the
-   * arguments.  This instruction is part of the implementation of
-   * `apply', and is not generated by the compiler.
-   */
-  VM_DEFINE_OP (14, tail_apply, "tail-apply", OP1 (X32))
+  VM_DEFINE_OP (14, unused_14, NULL, NOP)
     {
-      int i, list_idx, list_len, nlocals;
-      SCM list;
-
-      nlocals = FRAME_LOCALS_COUNT ();
-      // At a minimum, there should be apply, f, and the list.
-      VM_ASSERT (nlocals >= 3, abort ());
-      list_idx = nlocals - 1;
-      list = FP_REF (list_idx);
-
-      SYNC_IP ();
-      list_len = CALL_INTRINSIC (rest_arg_length, (list));
-
-      nlocals = nlocals - 2 + list_len;
-      ALLOC_FRAME (nlocals);
-
-      for (i = 1; i < list_idx; i++)
-        FP_SET (i - 1, FP_REF (i));
-
-      /* Null out these slots, just in case there are less than 2 elements
-         in the list. */
-      FP_SET (list_idx - 1, SCM_UNDEFINED);
-      FP_SET (list_idx, SCM_UNDEFINED);
-
-      for (i = 0; i < list_len; i++, list = SCM_CDR (list))
-        FP_SET (list_idx - 1 + i, SCM_CAR (list));
-
-      if (SCM_LIKELY (SCM_PROGRAM_P (FP_REF (0))))
-        ip = SCM_PROGRAM_CODE (FP_REF (0));
-      else
-        {
-          CALL_INTRINSIC (apply_non_program, (thread));
-          CACHE_REGISTER ();
-        }
-
-      APPLY_HOOK ();
-
-      NEXT (0);
+      vm_error_bad_instruction (op);
+      abort (); /* never reached */
     }
 
   /* call/cc _:24
@@ -1042,10 +969,30 @@ VM_NAME (scm_thread *thread)
       NEXT (1);
     }
 
-  VM_DEFINE_OP (30, unused_30, NULL, NOP)
+  /* expand-apply-argument _:24
+   *
+   * Take the last local in a frame and expand it out onto the stack, as
+   * for the last argument to "apply".
+   */
+  VM_DEFINE_OP (30, expand_apply_argument, "expand-apply-argument", OP1 (X32))
     {
-      vm_error_bad_instruction (op);
-      abort ();
+      int list_len;
+      SCM list;
+
+      list = SP_REF (0);
+
+      SYNC_IP ();
+      list_len = CALL_INTRINSIC (rest_arg_length, (list));
+
+      ALLOC_FRAME (FRAME_LOCALS_COUNT () - 1 + list_len);
+
+      while (list_len--)
+        {
+          SP_SET (list_len, SCM_CAR (list));
+          list = SCM_CDR (list);
+        }
+
+      NEXT (1);
     }
 
   /* bind-kwargs nreq:24 flags:8 nreq-and-opt:24 _:8 ntotal:24 kw-offset:32
diff --git a/libguile/vm.c b/libguile/vm.c
index 1f2373a..0e61120 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -335,11 +335,13 @@ static const uint32_t vm_boot_continuation_code[] = {
 
 static const uint32_t vm_builtin_apply_code[] = {
   SCM_PACK_OP_24 (assert_nargs_ge, 3),
-  SCM_PACK_OP_24 (tail_apply, 0), /* proc in r1, args from r2 */
+  SCM_PACK_OP_12_12 (shuffle_down, 1, 0),
+  SCM_PACK_OP_24 (expand_apply_argument, 0),
+  SCM_PACK_OP_24 (tail_call, 0),
 };
 
 static const uint32_t vm_builtin_values_code[] = {
-  SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */
+  SCM_PACK_OP_24 (return_values, 0)
 };
 
 static const uint32_t vm_builtin_abort_to_prompt_code[] = {
@@ -355,7 +357,8 @@ static const uint32_t vm_builtin_call_with_values_code[] = {
   SCM_PACK_OP_12_12 (mov, 0, 6),
   SCM_PACK_OP_24 (call, 7), SCM_PACK_OP_ARG_8_24 (0, 1),
   SCM_PACK_OP_24 (long_fmov, 0), SCM_PACK_OP_ARG_8_24 (0, 2),
-  SCM_PACK_OP_24 (tail_call_shuffle, 8)
+  SCM_PACK_OP_12_12 (shuffle_down, 8, 1),
+  SCM_PACK_OP_24 (tail_call, 0)
 };
 
 static const uint32_t vm_builtin_call_with_current_continuation_code[] = {
diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index 91ae19c..4b2f358 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -110,22 +110,28 @@
     (define (compile-tail label exp)
       ;; There are only three kinds of expressions in tail position:
       ;; tail calls, multiple-value returns, and single-value returns.
+      (define (maybe-reset-frame nlocals)
+        (unless (= frame-size nlocals)
+          (emit-reset-frame asm nlocals)))
       (match exp
         (($ $call proc args)
          (for-each (match-lambda
                     ((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
                    (lookup-parallel-moves label allocation))
-         (emit-tail-call asm (1+ (length args))))
+         (maybe-reset-frame (1+ (length args)))
+         (emit-tail-call asm))
         (($ $callk k proc args)
          (for-each (match-lambda
                     ((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
                    (lookup-parallel-moves label allocation))
-         (emit-tail-call-label asm (1+ (length args)) k))
+         (maybe-reset-frame (1+ (length args)))
+         (emit-tail-call-label asm k))
         (($ $values args)
          (for-each (match-lambda
                     ((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
                    (lookup-parallel-moves label allocation))
-         (emit-return-values asm (1+ (length args))))))
+         (maybe-reset-frame (1+ (length args)))
+         (emit-return-values asm))))
 
     (define (compile-value label exp dst)
       (match exp
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index e57e1ba..83d29f4 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -237,7 +237,6 @@
             emit-tail-call
             emit-tail-call-label
             emit-receive-values
-            emit-return
             emit-return-values
             emit-call/cc
             emit-abort
@@ -1562,7 +1561,7 @@ a procedure to do that and return its label.  Otherwise 
return
                         (assert-nargs-ee/locals 1 1)
                         ,@(reverse inits)
                         (load-constant 0 ,*unspecified*)
-                        (return-values 2)
+                        (return-values)
                         (end-program)))
            label))))
 
diff --git a/module/system/vm/disassembler.scm 
b/module/system/vm/disassembler.scm
index f46b160..8349933 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 ()