[Guile-commits] 05/07: Add indirect-tail-call VM instruction

[Andy Wingo]

wingo pushed a commit to branch wip-tailify
in repository guile.

commit 9a449f91b4f80e5db031ba064aabd5c55d3f72f4
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Tue May 25 14:13:37 2021 +0200

    Add indirect-tail-call VM instruction
    
    * libguile/vm-engine.c (indirect_tail_call): New instruction.
    * libguile/jit.c (compile_indirect_tail_call):
    (compile_indirect_tail_call_slow): Add JIT support.
    * module/system/vm/assembler.scm (system):
    * module/system/vm/disassembler.scm (instruction-has-fallthrough?):
    (stack-effect-parsers): Add assembler support.
---
 libguile/jit.c                    | 29 +++++++++++++++++++++++++++++
 libguile/vm-engine.c              | 17 ++++++++++++++++-
 module/system/vm/assembler.scm    |  1 +
 module/system/vm/disassembler.scm |  8 +++++---
 4 files changed, 51 insertions(+), 4 deletions(-)

diff --git a/libguile/jit.c b/libguile/jit.c
index 515882740..7d5b20a27 100644
--- a/libguile/jit.c
+++ b/libguile/jit.c
@@ -1647,6 +1647,35 @@ compile_tail_call_label_slow (scm_jit_state *j, const 
uint32_t *vcode)
 {
 }
 
+static void
+compile_indirect_tail_call (scm_jit_state *j)
+{
+  ASSERT_HAS_REGISTER_STATE (SP_IN_REGISTER);
+  restore_reloadable_register_state (j, FP_IN_REGISTER);
+
+  // Pop the vcode from the stack.
+  emit_sp_ref_ptr (j, T0, 0);
+  jit_addi (j->jit, SP, SP, sizeof (union scm_vm_stack_element));
+  emit_store_sp (j);
+
+  j->frame_size_min--;
+  if (j->frame_size_max != INT32_MAX)
+    j->frame_size_max--;
+
+  // See if there is mcode.  If so, jump there.
+  emit_get_ip_relative_addr (j, T1, T0, 1);
+  emit_ldxi (j, T1, T1, 0);
+  add_slow_path_patch (j, jit_beqi (j->jit, T1, 0));
+  ASSERT_HAS_REGISTER_STATE (FP_IN_REGISTER | SP_IN_REGISTER);
+  jit_jmpr (j->jit, T1);
+}
+static void
+compile_indirect_tail_call_slow (scm_jit_state *j)
+{
+  emit_store_ip (j, T0);
+  emit_exit (j);
+}
+
 static void
 compile_instrument_entry (scm_jit_state *j, void *data)
 {
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 510563ce4..f34bc8556 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -3478,7 +3478,22 @@ VM_NAME (scm_thread *thread)
       NEXT (4);
     }
 
-  VM_DEFINE_OP (167, unused_167, NULL, NOP)
+  /* indirect-tail-call _:24
+   *
+   * Pop a function pointer off the top of the stack and tail-call it.
+   */
+  VM_DEFINE_OP (167, indirect_tail_call, "indirect-tail-call", OP1 (X32))
+    {
+      VM_ASSERT (FRAME_LOCALS_COUNT () > 0, abort());
+
+      uint32_t *code = SP_REF_PTR (0);
+      VP->sp = sp = sp + 1;
+
+      ip = code;
+
+      NEXT (0);
+    }
+
   VM_DEFINE_OP (168, unused_168, NULL, NOP)
   VM_DEFINE_OP (169, unused_169, NULL, NOP)
   VM_DEFINE_OP (170, unused_170, NULL, NOP)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 33f3018f6..a655e0a55 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -282,6 +282,7 @@
 
             emit-call
             emit-call-label
+            emit-indirect-tail-call
             emit-tail-call
             emit-tail-call-label
             (emit-instrument-entry* . emit-instrument-entry)
diff --git a/module/system/vm/disassembler.scm 
b/module/system/vm/disassembler.scm
index ac1d21639..583af2aa8 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -1,6 +1,6 @@
 ;;; Guile bytecode disassembler
 
-;;; Copyright (C) 2001, 2009-2010, 2012-2015, 2017-2020, 2022 Free Software 
Foundation, Inc.
+;;; Copyright (C) 2001, 2009-2010, 2012-2015, 2017-2023 Free Software 
Foundation, Inc.
 ;;;
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -584,7 +584,7 @@ address of that offset."
   (define non-fallthrough-set
     (static-opcode-set halt
                        throw throw/value throw/value+data
-                       tail-call tail-call-label
+                       tail-call tail-call-label indirect-tail-call
                        return-values
                        subr-call foreign-call continuation-call
                        j jtable))
@@ -656,7 +656,9 @@ address of that offset."
                                 #xfff))
                  (nlocals (ash (bytevector-u32-native-ref code pos) -20)))
              (+ nargs nlocals))))
-      ((call call-label tail-call tail-call-label expand-apply-argument)
+      ((expand-apply-argument
+        call call-label
+        indirect-tail-call tail-call tail-call-label)
        #'(lambda (code pos size) #f))
       ((shuffle-down)
        #'(lambda (code pos size)