[Guile-commits] 01/06: Add bind-optionals instruction

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 9fd978ed7eebe32ceff7762eb87bba5d56a0743c
Author: Andy Wingo <address@hidden>
Date:   Thu Jun 6 16:20:20 2019 +0200

    Add bind-optionals instruction
    
    * doc/ref/vm.texi (Function Prologue Instructions): Document new
      instruction.
    * libguile/jit.c (compile_bind_optionals): New compiler.
    * libguile/vm-engine.c (VM_NAME): New interpreter.
    * module/system/vm/assembler.scm (opt-prelude): Emit bind-optionals as
      appropriate.
    * module/system/vm/disassembler.scm (define-stack-effect-parser)
      (code-annotation): Handle bind-optionals.
---
 doc/ref/vm.texi                   |  9 +++++++--
 libguile/jit.c                    | 31 +++++++++++++++++++++++++++++++
 libguile/vm-engine.c              | 23 ++++++++++++++++++++++-
 module/system/vm/assembler.scm    | 13 +++++++++----
 module/system/vm/disassembler.scm |  6 ++++--
 5 files changed, 73 insertions(+), 9 deletions(-)

diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index 5a0b5a7..e603204 100644
--- a/doc/ref/vm.texi
+++ b/doc/ref/vm.texi
@@ -807,6 +807,12 @@ will signal an error if an unknown key is found.
 A macro-mega-instruction.
 @end deftypefn
 
+@deftypefn Instruction {} bind-optionals f24:@var{nlocals}
+Expand the current frame to have at least @var{nlocals} locals, filling
+in any fresh values with @code{SCM_UNDEFINED}.  If the frame has more
+than @var{nlocals} locals, it is left as it is.
+@end deftypefn
+
 @deftypefn Instruction {} bind-rest f24:@var{dst}
 Collect any arguments at or above @var{dst} into a list, and store that
 list at @var{dst}.
@@ -814,8 +820,7 @@ list at @var{dst}.
 
 @deftypefn Instruction {} alloc-frame c24:@var{nlocals}
 Ensure that there is space on the stack for @var{nlocals} local
-variables, setting them all to @code{SCM_UNDEFINED}, except those values
-that are already on the stack.
+variables.  The value of any new local is undefined.
 @end deftypefn
 
 @deftypefn Instruction {} reset-frame c24:@var{nlocals}
diff --git a/libguile/jit.c b/libguile/jit.c
index d09c3ad..4e4a355 100644
--- a/libguile/jit.c
+++ b/libguile/jit.c
@@ -2006,6 +2006,37 @@ compile_bind_rest (scm_jit_state *j, uint32_t dst)
 }
 
 static void
+compile_bind_optionals (scm_jit_state *j, uint32_t dst)
+{
+  ASSERT_HAS_REGISTER_STATE (FP_IN_REGISTER | SP_IN_REGISTER);
+  ASSERT(j->frame_size == -1);
+
+  jit_gpr_t saved_frame_size = T1_PRESERVED;
+  jit_subr (j->jit, saved_frame_size, FP, SP);
+
+  jit_reloc_t no_optionals = jit_bgei
+    (j->jit, saved_frame_size, dst * sizeof (union scm_vm_stack_element));
+
+  emit_alloc_frame (j, T0, dst);
+
+  jit_gpr_t walk = saved_frame_size;
+  jit_subr (j->jit, walk, FP, saved_frame_size);
+
+  jit_reloc_t done = jit_bler (j->jit, walk, SP);
+  jit_movi (j->jit, T0, SCM_UNPACK (SCM_UNDEFINED));
+
+  void *head = jit_address (j->jit);
+  jit_subi (j->jit, walk, walk, sizeof (union scm_vm_stack_element));
+  jit_str (j->jit, walk, T0);
+  jit_patch_there (j->jit, jit_bner (j->jit, walk, SP), head);
+
+  jit_patch_here (j->jit, done);
+  jit_patch_here (j->jit, no_optionals);
+
+  ASSERT(j->frame_size == -1);
+}
+
+static void
 compile_allocate_words (scm_jit_state *j, uint16_t dst, uint16_t nwords)
 {
   jit_gpr_t t = T0;
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 062dc00..a2e4be5 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -3231,7 +3231,28 @@ VM_NAME (scm_thread *thread)
   VM_DEFINE_OP (153, f64_set, "f64-set!", OP1 (X8_S8_S8_S8))
     PTR_SET (double, F64);
 
-  VM_DEFINE_OP (154, unused_154, NULL, NOP)
+  /* bind-optionals nargs:24
+   *
+   * Expand the current frame to have NARGS locals, filling in any fresh
+   * values with SCM_UNDEFINED.
+   */
+  VM_DEFINE_OP (154, bind_optionals, "bind-optionals", DOP1 (X8_F24))
+    {
+      uint32_t nlocals, nargs;
+
+      UNPACK_24 (op, nlocals);
+      nargs = FRAME_LOCALS_COUNT ();
+
+      if (nargs < nlocals)
+        {
+          ALLOC_FRAME (nlocals);
+          while (nargs < nlocals)
+            FP_SET (nargs++, SCM_UNDEFINED);
+        }
+
+      NEXT (1);
+    }
+
   VM_DEFINE_OP (155, unused_155, NULL, NOP)
   VM_DEFINE_OP (156, unused_156, NULL, NOP)
   VM_DEFINE_OP (157, unused_157, NULL, NOP)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index f3682f7..9477cb9 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1,6 +1,6 @@
 ;;; Guile bytecode assembler
 
-;;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014, 2015, 2017, 2018 Free 
Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009-2019 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
@@ -246,7 +246,6 @@
             emit-assert-nargs-ee
             emit-assert-nargs-ge
             emit-assert-nargs-le
-            emit-alloc-frame
             emit-reset-frame
             emit-assert-nargs-ee/locals
             emit-bind-kwargs
@@ -1478,6 +1477,8 @@ returned instead."
       (emit-assert-nargs-ge asm nreq))
   (cond
    (rest?
+    (unless (zero? nopt)
+      (emit-bind-optionals asm (+ nreq nopt)))
     (emit-bind-rest asm (+ nreq nopt)))
    (alternate
     (emit-arguments<=? asm (+ nreq nopt))
@@ -1485,9 +1486,13 @@ returned instead."
     ;; whereas for <, NONE usually indicates greater-than-or-equal,
     ;; hence the name jge.  Perhaps we just need to rename jge to
     ;; br-if-none.
-    (emit-jge asm alternate))
+    (emit-jge asm alternate)
+    (unless (zero? nopt)
+      (emit-bind-optionals asm (+ nreq nopt))))
    (else
-    (emit-assert-nargs-le asm (+ nreq nopt))))
+    (emit-assert-nargs-le asm (+ nreq nopt))
+    (unless (zero? nopt)
+      (emit-bind-optionals asm (+ nreq nopt)))))
   (emit-alloc-frame asm nlocals))
 
 (define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices
diff --git a/module/system/vm/disassembler.scm 
b/module/system/vm/disassembler.scm
index 8349933..73910fd 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-2018 Free Software 
Foundation, Inc.
+;;; Copyright (C) 2001, 2009-2010, 2012-2015, 2017-2019 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
@@ -231,6 +231,8 @@ address of that offset."
     (('assert-nargs-ee/locals nargs locals)
      ;; The nargs includes the procedure.
      (list "~a slot~:p (~a arg~:p)" (+ locals nargs) (1- nargs)))
+    (('bind-optionals nargs)
+     (list "~a args~:p" (1- nargs)))
     (('alloc-frame nlocals)
      (list "~a slot~:p" nlocals))
     (('reset-frame nlocals)
@@ -546,7 +548,7 @@ address of that offset."
          #'(lambda (code pos size)
              (let ((count (ash (bytevector-u32-native-ref code pos) -8)))
                (and size (- size count)))))
-        ((alloc-frame reset-frame)
+        ((alloc-frame reset-frame bind-optionals)
          #'(lambda (code pos size)
              (let ((nlocals (ash (bytevector-u32-native-ref code pos) -8)))
                nlocals)))