mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 22:31:12 +02:00
Code Activity

Apply-non-program is an intrinsic

Browse source 
* libguile/intrinsics.h (SCM_FOR_ALL_VM_INTRINSICS): Add
  apply-non-program intrinsic.
* libguile/vm-engine.c (apply-non-program): Replace impl with call to
  intrinsic.
* libguile/vm.c (vm_error_wrong_type_apply): Inline into
  apply_non_program intrinsic.
  (apply_non_program): New intrinsic.
  (scm_bootstrap_vm): Wire it up.
This commit is contained in:
Andy Wingo 2018-06-27 13:38:30 +02:00
parent adf8d9353e
commit 1735cc1fec
3 changed files with 46 additions and 38 deletions
Download patch file Download diff file Expand all files Collapse all files

1
libguile/intrinsics.h
View file

@ -124,6 +124,7 @@ typedef void (*scm_t_u32_noreturn_intrinsic) (uint32_t) SCM_NORETURN;
M(noreturn, error_no_values, "no-values", ERROR_NO_VALUES) \
M(noreturn, error_not_enough_values, "not-enough-values", ERROR_NOT_ENOUGH_VALUES) \
M(u32_noreturn, error_wrong_number_of_values, "wrong-number-of-values", ERROR_WRONG_NUMBER_OF_VALUES) \
M(thread, apply_non_program, "apply-non-program", APPLY_NON_PROGRAM) \
/* Add new intrinsics here; also update scm_bootstrap_intrinsics. */
enum scm_vm_intrinsic

33
libguile/vm-engine.c
View file

@ -2033,36 +2033,9 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int resume)
*/
VM_DEFINE_OP (142, apply_non_program, "apply-non-program", OP1 (X32))
{
SCM proc = FP_REF (0);
while (!SCM_PROGRAM_P (proc))
{
if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
{
proc = SCM_STRUCT_PROCEDURE (proc);
FP_SET (0, proc);
continue;
}
if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (proc))
{
uint32_t n = FRAME_LOCALS_COUNT();
/* Shuffle args up. (FIXME: no real need to shuffle; just set
IP and go. ) */
ALLOC_FRAME (n + 1);
while (n--)
FP_SET (n + 1, FP_REF (n));
proc = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline;
FP_SET (0, proc);
continue;
}
SYNC_IP();
vm_error_wrong_type_apply (proc);
}
ip = SCM_PROGRAM_CODE (proc);
SYNC_IP ();
scm_vm_intrinsics.apply_non_program (thread);
CACHE_REGISTER ();
NEXT (0);
}

50
libguile/vm.c
View file

@ -308,7 +308,6 @@ static void vm_dispatch_abort_hook (struct scm_vm *vp)
static void vm_error_bad_instruction (uint32_t inst) SCM_NORETURN SCM_NOINLINE;
static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE;
static void
vm_error_bad_instruction (uint32_t inst)
@ -317,13 +316,6 @@ vm_error_bad_instruction (uint32_t inst)
abort ();
}
static void
vm_error_wrong_type_apply (SCM proc)
{
scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S",
scm_list_1 (proc), scm_list_1 (proc));
}
@ -1332,6 +1324,47 @@ abort_to_prompt (scm_thread *thread, jmp_buf *current_registers)
longjmp (*registers, 1);
}
static void
apply_non_program (scm_thread *thread)
{
struct scm_vm *vp = &thread->vm;
SCM proc = SCM_FRAME_LOCAL (vp->fp, 0);
while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
{
proc = SCM_STRUCT_PROCEDURE (proc);
SCM_FRAME_LOCAL (vp->fp, 0) = proc;
if (SCM_PROGRAM_P (proc))
{
vp->ip = SCM_PROGRAM_CODE (proc);
return;
}
}
if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (proc))
{
uint32_t n = frame_locals_count (thread);
alloc_frame (thread, n + 1);
/* Although we could make VM modifications to avoid this shuffle,
it's easier to piggy-back on the subr arg parsing machinery.
Hopefully applicable smobs will go away in the mid-term. */
while (n--)
SCM_FRAME_LOCAL (vp->fp, n + 1) = SCM_FRAME_LOCAL (vp->fp, n);
proc = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline;
SCM_FRAME_LOCAL (vp->fp, 0) = proc;
vp->ip = SCM_PROGRAM_CODE (proc);
return;
}
scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S",
scm_list_1 (proc), scm_list_1 (proc));
}
SCM
scm_call_n (SCM proc, SCM *argv, size_t nargs)
{
@ -1680,6 +1713,7 @@ scm_bootstrap_vm (void)
scm_vm_intrinsics.compose_continuation = compose_continuation;
scm_vm_intrinsics.rest_arg_length = rest_arg_length;
scm_vm_intrinsics.abort_to_prompt = abort_to_prompt;
scm_vm_intrinsics.apply_non_program = apply_non_program;
sym_keyword_argument_error = scm_from_latin1_symbol ("keyword-argument-error");
sym_regular = scm_from_latin1_symbol ("regular");