diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 45c3928a0..e44f21169 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -888,10 +888,9 @@ compiler probably shouldn't emit code with these instructions. However, it's still interesting to know how these things work, so we document these trampoline instructions here. -@deftypefn Instruction {} subr-call c24:@var{ptr-idx} -Call a subr, passing all locals in this frame as arguments. Fetch the -foreign pointer from @var{ptr-idx}, a free variable. Return from the -calling frame. +@deftypefn Instruction {} subr-call x24:@var{_} +Call a subr, passing all locals in this frame as arguments. Return from +the calling frame. @end deftypefn @deftypefn Instruction {} foreign-call c12:@var{cif-idx} c12:@var{ptr-idx} diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 329241da2..a3b804bb5 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995-2001, 2006, 2008-2011, 2013 +/* Copyright (C) 1995-2001, 2006, 2008-2011, 2013, 2015 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -295,6 +295,47 @@ scm_i_primitive_call_ip (SCM subr) return (scm_t_uintptr)(code + (code[3] ? 3 : code[2] ? 2 : 1)); } +SCM +scm_apply_subr (union scm_vm_stack_element *sp, scm_t_ptrdiff nslots) +{ + SCM (*subr)() = SCM_SUBRF (sp[nslots - 1].as_scm); + +#define ARG(i) (sp[i].as_scm) + switch (nslots - 1) + { + case 0: + return subr (); + case 1: + return subr (ARG (0)); + case 2: + return subr (ARG (1), ARG (0)); + case 3: + return subr (ARG (2), ARG (1), ARG (0)); + case 4: + return subr (ARG (3), ARG (2), ARG (1), ARG (0)); + case 5: + return subr (ARG (4), ARG (3), ARG (2), ARG (1), ARG (0)); + case 6: + return subr (ARG (5), ARG (4), ARG (3), ARG (2), ARG (1), + ARG (0)); + case 7: + return subr (ARG (6), ARG (5), ARG (4), ARG (3), ARG (2), + ARG (1), ARG (0)); + case 8: + return subr (ARG (7), ARG (6), ARG (5), ARG (4), ARG (3), + ARG (2), ARG (1), ARG (0)); + case 9: + return subr (ARG (8), ARG (7), ARG (6), ARG (5), ARG (4), + ARG (3), ARG (2), ARG (1), ARG (0)); + case 10: + return subr (ARG (9), ARG (8), ARG (7), ARG (6), ARG (5), + ARG (4), ARG (3), ARG (2), ARG (1), ARG (0)); + default: + abort (); + } +#undef ARG +} + SCM scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)()) { diff --git a/libguile/gsubr.h b/libguile/gsubr.h index 065b94766..a9db85e44 100644 --- a/libguile/gsubr.h +++ b/libguile/gsubr.h @@ -4,7 +4,7 @@ #define SCM_GSUBR_H /* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2006, 2008, 2009, - * 2010, 2011, 2013 Free Software Foundation, Inc. + * 2010, 2011, 2013, 2015 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 License @@ -57,6 +57,10 @@ SCM_INTERNAL int scm_i_primitive_arity (SCM subr, int *req, int *opt, int *rest); SCM_INTERNAL scm_t_uintptr scm_i_primitive_call_ip (SCM subr); +union scm_vm_stack_element; +SCM_INTERNAL SCM scm_apply_subr (union scm_vm_stack_element *sp, + scm_t_ptrdiff nargs); + SCM_API SCM scm_c_make_gsubr (const char *name, int req, int opt, int rst, scm_t_subr fcn); SCM_API SCM scm_c_make_gsubr_with_generic (const char *name, diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 308c04cd9..d5f68578d 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -781,77 +781,19 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Specialized call stubs */ - /* subr-call ptr-idx:24 + /* subr-call _:24 * - * Call a subr, passing all locals in this frame as arguments. Fetch - * the foreign pointer from PTR-IDX, a free variable. Return from the - * calling frame. This instruction is part of the trampolines - * created in gsubr.c, and is not generated by the compiler. + * Call a subr, passing all locals in this frame as arguments. Return + * from the calling frame. This instruction is part of the + * trampolines created in gsubr.c, and is not generated by the + * compiler. */ - VM_DEFINE_OP (10, subr_call, "subr-call", OP1 (X8_C24)) + VM_DEFINE_OP (10, subr_call, "subr-call", OP1 (X32)) { - scm_t_uint32 ptr_idx; - SCM pointer, ret; - SCM (*subr)(); - - UNPACK_24 (op, ptr_idx); - - pointer = SCM_PROGRAM_FREE_VARIABLE_REF (FP_REF (0), ptr_idx); - subr = SCM_POINTER_VALUE (pointer); + SCM ret; SYNC_IP (); - - switch (FRAME_LOCALS_COUNT_FROM (1)) - { - case 0: - ret = subr (); - break; - case 1: - ret = subr (SP_REF (0)); - break; - case 2: - ret = subr (SP_REF (1), SP_REF (0)); - break; - case 3: - ret = subr (SP_REF (2), SP_REF (1), SP_REF (0)); - break; - case 4: - ret = subr (SP_REF (3), SP_REF (2), SP_REF (1), - SP_REF (0)); - break; - case 5: - ret = subr (SP_REF (4), SP_REF (3), SP_REF (2), - SP_REF (1), SP_REF (0)); - break; - case 6: - ret = subr (SP_REF (5), SP_REF (4), SP_REF (3), - SP_REF (2), SP_REF (1), SP_REF (0)); - break; - case 7: - ret = subr (SP_REF (6), SP_REF (5), SP_REF (4), - SP_REF (3), SP_REF (2), SP_REF (1), - SP_REF (0)); - break; - case 8: - ret = subr (SP_REF (7), SP_REF (6), SP_REF (5), - SP_REF (4), SP_REF (3), SP_REF (2), - SP_REF (1), SP_REF (0)); - break; - case 9: - ret = subr (SP_REF (8), SP_REF (7), SP_REF (6), - SP_REF (5), SP_REF (4), SP_REF (3), - SP_REF (2), SP_REF (1), SP_REF (0)); - break; - case 10: - ret = subr (SP_REF (9), SP_REF (8), SP_REF (7), - SP_REF (6), SP_REF (5), SP_REF (4), - SP_REF (3), SP_REF (2), SP_REF (1), - SP_REF (0)); - break; - default: - abort (); - } - + ret = scm_apply_subr (sp, FRAME_LOCALS_COUNT ()); CACHE_SP (); if (SCM_UNLIKELY (SCM_VALUESP (ret)))