summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2019-06-06 16:20:20 +0200
committerAndy Wingo <wingo@pobox.com>2019-06-06 16:36:32 +0200
commit9fd978ed7eebe32ceff7762eb87bba5d56a0743c (patch)
treee2b7e28c42924c1c5aced9f56cdbdec525c5146c
parent12d6e4317657e4334306b1345a09a11b0e256fa3 (diff)
downloadguile-9fd978ed7eebe32ceff7762eb87bba5d56a0743c.tar.gz
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.
-rw-r--r--doc/ref/vm.texi9
-rw-r--r--libguile/jit.c31
-rw-r--r--libguile/vm-engine.c23
-rw-r--r--module/system/vm/assembler.scm13
-rw-r--r--module/system/vm/disassembler.scm6
5 files changed, 73 insertions, 9 deletions
diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index 5a0b5a739..e603204ca 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 d09c3ad5d..4e4a35506 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 062dc00bd..a2e4be57a 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 f3682f7e8..9477cb932 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 83499333c..73910fda0 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)))