-/* Copyright (C) 2001, 2008, 2009, 2010, 2011,
- * 2012 Free Software Foundation, Inc.
- *
+/* Copyright (C) 2001,2008,2009,2010,2011,2012,2013 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
* as published by the Free Software Foundation; either version 3 of
/* This file is included in vm_engine.c */
-/* Compiler barrier, to prevent instruction reordering, apparently due
- to a bug in GCC 4.3.2 on sparc-linux-gnu and on hppa2.0-linux-gnu.
- See <http://bugs.gnu.org/10520>, for details. */
-
-#ifdef __GNUC__
-# define COMPILER_BARRIER __asm__ __volatile__ ("")
-#else
-# define COMPILER_BARRIER do { } while (0)
-#endif
-
-
\f
/*
* Basic operations
VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
{
- nvalues = SCM_I_INUM (*sp--);
+ SCM ret;
+ SCM nvalues_scm;
+
+ nvalues_scm = *sp--; /* SCM_I_INUM may evaluate its argument
+ more than once. */
+ nvalues = SCM_I_INUM (nvalues_scm);
NULLSTACK (1);
+
if (nvalues == 1)
- POP (finish_args);
+ POP (ret);
else
{
- POP_LIST (nvalues);
- POP (finish_args);
SYNC_REGISTER ();
- finish_args = scm_values (finish_args);
+ sp -= nvalues;
+ CHECK_UNDERFLOW ();
+ ret = scm_c_values (sp + 1, nvalues);
+ NULLSTACK (nvalues);
}
{
stack */
ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
- COMPILER_BARRIER;
NULLSTACK (old_sp - sp);
}
- goto vm_done;
+ SYNC_ALL ();
+ return ret;
}
VM_DEFINE_INSTRUCTION (2, drop, "drop", 0, 1, 0)
{
SCM x = *sp;
PUSH (x);
- DEAD (x);
NEXT;
}
memcpy (SCM_I_VECTOR_WELTS(vect), sp, sizeof(SCM) * len);
NULLSTACK (len);
*sp = vect;
- DEAD (vect);
NEXT;
}
unlike in top-variable-ref, it really isn't an internal assertion
that can be optimized out -- the variable could be coming directly
from the user. */
- if (SCM_UNLIKELY (!SCM_VARIABLEP (x)))
- {
- func_name = "variable-ref";
- finish_args = x;
- goto vm_error_not_a_variable;
- }
- else if (SCM_UNLIKELY (!VARIABLE_BOUNDP (x)))
+ VM_ASSERT (SCM_VARIABLEP (x),
+ vm_error_not_a_variable ("variable-ref", x));
+
+ if (SCM_UNLIKELY (!VARIABLE_BOUNDP (x)))
{
SCM var_name;
+ SYNC_ALL ();
/* Attempt to provide the variable name in the error message. */
var_name = scm_module_reverse_lookup (scm_current_module (), x);
- finish_args = scm_is_true (var_name) ? var_name : x;
- goto vm_error_unbound;
+ vm_error_unbound (program, scm_is_true (var_name) ? var_name : x);
}
else
{
SCM o = VARIABLE_REF (x);
*sp = o;
- DEAD (o);
}
NEXT;
{
SCM x = *sp;
- if (SCM_UNLIKELY (!SCM_VARIABLEP (x)))
- {
- func_name = "variable-bound?";
- finish_args = x;
- goto vm_error_not_a_variable;
- }
- else
- *sp = scm_from_bool (VARIABLE_BOUNDP (x));
- DEAD (x);
+ VM_ASSERT (SCM_VARIABLEP (x),
+ vm_error_not_a_variable ("variable-bound?", x));
+
+ *sp = scm_from_bool (VARIABLE_BOUNDP (x));
NEXT;
}
VM_DEFINE_INSTRUCTION (27, toplevel_ref, "toplevel-ref", 1, 0, 1)
{
unsigned objnum = FETCH ();
- SCM what;
+ SCM what, resolved;
CHECK_OBJECT (objnum);
what = OBJECT_REF (objnum);
if (!SCM_VARIABLEP (what))
{
- SCM resolved;
SYNC_REGISTER ();
resolved = resolve_variable (what, scm_program_module (program));
- if (!VARIABLE_BOUNDP (resolved))
- {
- finish_args = what;
- goto vm_error_unbound;
- }
+ VM_ASSERT (VARIABLE_BOUNDP (resolved), vm_error_unbound (program, what));
what = resolved;
- DEAD (resolved);
OBJECT_SET (objnum, what);
}
PUSH (VARIABLE_REF (what));
- DEAD (what);
NEXT;
}
VM_DEFINE_INSTRUCTION (28, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
{
- SCM what;
+ SCM what, resolved;
unsigned int objnum = FETCH ();
objnum <<= 8;
objnum += FETCH ();
if (!SCM_VARIABLEP (what))
{
- SCM resolved;
SYNC_REGISTER ();
resolved = resolve_variable (what, scm_program_module (program));
- if (!VARIABLE_BOUNDP (resolved))
- {
- finish_args = what;
- goto vm_error_unbound;
- }
+ VM_ASSERT (VARIABLE_BOUNDP (resolved),
+ vm_error_unbound (program, what));
what = resolved;
- DEAD (resolved);
OBJECT_SET (objnum, what);
}
PUSH (VARIABLE_REF (what));
- DEAD (what);
NEXT;
}
SCM x;
POP (x);
LOCAL_SET (FETCH (), x);
- DEAD (x);
NEXT;
}
i += FETCH ();
POP (x);
LOCAL_SET (i, x);
- DEAD (x);
NEXT;
}
VM_DEFINE_INSTRUCTION (31, variable_set, "variable-set", 0, 2, 0)
{
- if (SCM_UNLIKELY (!SCM_VARIABLEP (sp[0])))
- {
- func_name = "variable-set!";
- finish_args = sp[0];
- goto vm_error_not_a_variable;
- }
+ VM_ASSERT (SCM_VARIABLEP (sp[0]),
+ vm_error_not_a_variable ("variable-set!", sp[0]));
VARIABLE_SET (sp[0], sp[-1]);
DROPN (2);
NEXT;
}
VARIABLE_SET (what, *sp);
- DEAD (what);
DROP ();
NEXT;
}
}
VARIABLE_SET (what, *sp);
- DEAD (what);
DROP ();
NEXT;
}
ip += offset; \
if (offset < 0) \
VM_HANDLE_INTERRUPTS; \
+ NEXT; \
}
VM_DEFINE_INSTRUCTION (34, br, "br", 3, 0, 0)
SCM x;
POP (x);
BR (scm_is_true (x));
- DEAD (x);
- NEXT;
}
VM_DEFINE_INSTRUCTION (36, br_if_not, "br-if-not", 3, 0, 0)
SCM x;
POP (x);
BR (scm_is_false (x));
- DEAD (x);
- NEXT;
}
VM_DEFINE_INSTRUCTION (37, br_if_eq, "br-if-eq", 3, 0, 0)
SCM x, y;
POP2 (y, x);
BR (scm_is_eq (x, y));
- DEAD (x);
- DEAD (y);
- NEXT;
}
VM_DEFINE_INSTRUCTION (38, br_if_not_eq, "br-if-not-eq", 3, 0, 0)
SCM x, y;
POP2 (y, x);
BR (!scm_is_eq (x, y));
- DEAD (x);
- DEAD (y);
- NEXT;
}
VM_DEFINE_INSTRUCTION (39, br_if_null, "br-if-null", 3, 0, 0)
SCM x;
POP (x);
BR (scm_is_null (x));
- DEAD (x);
- NEXT;
}
VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0)
SCM x;
POP (x);
BR (!scm_is_null (x));
- DEAD (x);
- NEXT;
}
\f
scm_t_ptrdiff n;
n = FETCH () << 8;
n += FETCH ();
- if (sp - (fp - 1) != n)
- goto vm_error_wrong_num_args;
+ VM_ASSERT (sp - (fp - 1) == n,
+ vm_error_wrong_num_args (program));
NEXT;
}
scm_t_ptrdiff n;
n = FETCH () << 8;
n += FETCH ();
- if (sp - (fp - 1) < n)
- goto vm_error_wrong_num_args;
+ VM_ASSERT (sp - (fp - 1) >= n,
+ vm_error_wrong_num_args (program));
NEXT;
}
NEXT;
}
+/* See also bind-optionals/shuffle-or-br below. */
+
/* Flags that determine whether other keywords are allowed, and whether a
rest argument is expected. These values must match those used by the
glil->assembly compiler. */
nkw += FETCH ();
kw_and_rest_flags = FETCH ();
- if (!(kw_and_rest_flags & F_REST)
- && ((sp - (fp - 1) - nkw) % 2))
- goto vm_error_kwargs_length_not_even;
+ VM_ASSERT ((kw_and_rest_flags & F_REST)
+ || ((sp - (fp - 1) - nkw) % 2) == 0,
+ vm_error_kwargs_length_not_even (program))
CHECK_OBJECT (idx);
kw = OBJECT_REF (idx);
break;
}
}
- if (!(kw_and_rest_flags & F_ALLOW_OTHER_KEYS) && !scm_is_pair (walk))
- goto vm_error_kwargs_unrecognized_keyword;
-
+ VM_ASSERT (scm_is_pair (walk)
+ || (kw_and_rest_flags & F_ALLOW_OTHER_KEYS),
+ vm_error_kwargs_unrecognized_keyword (program, sp[nkw]));
nkw++;
}
- else if (!(kw_and_rest_flags & F_REST))
- goto vm_error_kwargs_invalid_keyword;
+ else
+ VM_ASSERT (kw_and_rest_flags & F_REST,
+ vm_error_kwargs_invalid_keyword (program, sp[nkw]));
}
- DEAD (kw);
-
NEXT;
}
/* No need to check for underflow. */
CONS (rest, *sp--, rest);
PUSH (rest);
- DEAD (rest);
NEXT;
}
/* No need to check for underflow. */
CONS (rest, *sp--, rest);
LOCAL_SET (i, rest);
- DEAD (rest);
NEXT;
}
nargs = FETCH ();
vm_call:
- program = sp[-nargs];
-
VM_HANDLE_INTERRUPTS;
- if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
- {
- if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
- {
- sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
- goto vm_call;
- }
- else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
- && SCM_SMOB_APPLICABLE_P (program))
- {
- SYNC_REGISTER ();
- sp[-nargs] = scm_i_smob_apply_trampoline (program);
- goto vm_call;
- }
- else
- goto vm_error_wrong_type_apply;
- }
-
- CACHE_PROGRAM ();
-
{
SCM *old_fp = fp;
SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
}
- ip = SCM_C_OBJCODE_BASE (bp);
PUSH_CONTINUATION_HOOK ();
+
+ program = fp[-1];
+
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
+ goto apply;
+
+ CACHE_PROGRAM ();
+ ip = SCM_C_OBJCODE_BASE (bp);
+
APPLY_HOOK ();
NEXT;
}
nargs = FETCH ();
vm_tail_call:
- program = sp[-nargs];
-
VM_HANDLE_INTERRUPTS;
- if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
- {
- if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
- {
- sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
- goto vm_tail_call;
- }
- else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
- && SCM_SMOB_APPLICABLE_P (program))
- {
- SYNC_REGISTER ();
- sp[-nargs] = scm_i_smob_apply_trampoline (program);
- goto vm_tail_call;
- }
- else
- goto vm_error_wrong_type_apply;
- }
- else
- {
- int i;
+ {
+ int i;
#ifdef VM_ENABLE_STACK_NULLING
- SCM *old_sp = sp;
- CHECK_STACK_LEAK ();
+ SCM *old_sp = sp;
+ CHECK_STACK_LEAK ();
#endif
- /* switch programs */
- CACHE_PROGRAM ();
- /* shuffle down the program and the arguments */
- for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
- SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i];
+ /* shuffle down the program and the arguments */
+ for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
+ SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i];
- sp = fp + i - 1;
+ sp = fp + i - 1;
- NULLSTACK (old_sp - sp);
+ NULLSTACK (old_sp - sp);
+ }
- ip = SCM_C_OBJCODE_BASE (bp);
+ program = fp[-1];
- APPLY_HOOK ();
- NEXT;
- }
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
+ goto apply;
+
+ CACHE_PROGRAM ();
+ ip = SCM_C_OBJCODE_BASE (bp);
+
+ APPLY_HOOK ();
+ NEXT;
}
VM_DEFINE_INSTRUCTION (55, subr_call, "subr-call", 1, -1, -1)
abort ();
}
- DEAD (pointer);
NULLSTACK_FOR_NONLOCAL_EXIT ();
if (SCM_UNLIKELY (SCM_VALUESP (ret)))
ret = scm_struct_ref (ret, SCM_INUM0);
nvalues = scm_ilength (ret);
PUSH_LIST (ret, scm_is_null);
- DEAD (ret);
goto vm_return_values;
}
else
{
PUSH (ret);
- DEAD (ret);
goto vm_return;
}
}
abort ();
}
- DEAD (smob);
NULLSTACK_FOR_NONLOCAL_EXIT ();
if (SCM_UNLIKELY (SCM_VALUESP (ret)))
ret = scm_struct_ref (ret, SCM_INUM0);
nvalues = scm_ilength (ret);
PUSH_LIST (ret, scm_is_null);
- DEAD (ret);
goto vm_return_values;
}
else
{
PUSH (ret);
- DEAD (ret);
goto vm_return;
}
}
ret = scm_i_foreign_call (foreign, sp - nargs + 1);
- DEAD (foreign);
NULLSTACK_FOR_NONLOCAL_EXIT ();
if (SCM_UNLIKELY (SCM_VALUESP (ret)))
ret = scm_struct_ref (ret, SCM_INUM0);
nvalues = scm_ilength (ret);
PUSH_LIST (ret, scm_is_null);
- DEAD (ret);
goto vm_return_values;
}
else
{
PUSH (ret);
- DEAD (ret);
goto vm_return;
}
}
sp - (fp - 1), fp);
scm_i_reinstate_continuation (contregs);
- /* no DEAD, no NEXT */
+ /* no NEXT */
abort ();
}
SCM vmcont, intwinds, prevwinds;
POP2 (intwinds, vmcont);
SYNC_REGISTER ();
- if (SCM_UNLIKELY (!SCM_VM_CONT_REWINDABLE_P (vmcont)))
- {
- finish_args = vmcont;
- goto vm_error_continuation_not_rewindable;
- }
+ VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont),
+ vm_error_continuation_not_rewindable (vmcont));
prevwinds = scm_i_dynwinds ();
vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp,
vm_cookie);
- DEAD (vmcont);
- DEAD (intwinds);
/* Rewind prompt jmpbuffers, if any. */
{
for (; !scm_is_eq (winds, prevwinds); winds = scm_cdr (winds))
if (SCM_PROMPT_P (scm_car (winds)) && SCM_PROMPT_SETJMP (scm_car (winds)))
break;
- DEAD (winds);
}
- DEAD (prevwinds);
CACHE_REGISTER ();
program = SCM_FRAME_PROGRAM (fp);
SCM x;
POP (x);
nargs = scm_to_int (x);
- DEAD (x);
/* FIXME: should truncate values? */
goto vm_tail_call;
}
SCM x;
POP (x);
nargs = scm_to_int (x);
- DEAD (x);
/* FIXME: should truncate values? */
goto vm_call;
}
{
scm_t_int32 offset;
scm_t_uint8 *mvra;
+ SCM *old_fp = fp;
nargs = FETCH ();
FETCH_OFFSET (offset);
mvra = ip + offset;
- vm_mv_call:
- program = sp[-nargs];
-
VM_HANDLE_INTERRUPTS;
- if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
- {
- if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
- {
- sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
- goto vm_mv_call;
- }
- else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
- && SCM_SMOB_APPLICABLE_P (program))
- {
- SYNC_REGISTER ();
- sp[-nargs] = scm_i_smob_apply_trampoline (program);
- goto vm_mv_call;
- }
- else
- goto vm_error_wrong_type_apply;
- }
+ fp = sp - nargs + 1;
+
+ ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
+ ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
+ ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
+ SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
+ SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
+ SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
+
+ PUSH_CONTINUATION_HOOK ();
- CACHE_PROGRAM ();
+ program = fp[-1];
- {
- SCM *old_fp = fp;
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
+ goto apply;
- fp = sp - nargs + 1;
-
- ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
- ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
- ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
- SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
- SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
- SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
- }
-
+ CACHE_PROGRAM ();
ip = SCM_C_OBJCODE_BASE (bp);
- PUSH_CONTINUATION_HOOK ();
+
APPLY_HOOK ();
NEXT;
}
ASSERT (nargs >= 2);
len = scm_ilength (ls);
- if (SCM_UNLIKELY (len < 0))
- {
- finish_args = ls;
- goto vm_error_apply_to_non_list;
- }
-
+ VM_ASSERT (len >= 0,
+ vm_error_apply_to_non_list (ls));
PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
- DEAD (ls);
nargs += len - 2;
goto vm_call;
ASSERT (nargs >= 2);
len = scm_ilength (ls);
- if (SCM_UNLIKELY (len < 0))
- {
- finish_args = ls;
- goto vm_error_apply_to_non_list;
- }
-
+ VM_ASSERT (len >= 0,
+ vm_error_apply_to_non_list (ls));
PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
- DEAD (ls);
nargs += len - 2;
goto vm_tail_call;
SYNC_ALL ();
vm_cont = scm_i_vm_capture_stack (vp->stack_base, fp, sp, ip, NULL, 0);
cont = scm_i_make_continuation (&first, vm, vm_cont);
- DEAD (vm_cont);
if (first)
{
PUSH (SCM_PACK (0)); /* dynamic link */
PUSH (SCM_PACK (0)); /* mvra */
PUSH (SCM_PACK (0)); /* ra */
PUSH (proc);
- DEAD (proc);
PUSH (cont);
- DEAD (cont);
nargs = 1;
goto vm_call;
}
So, pull our regs back down from the vp, and march on to the
next instruction. */
- DEAD (proc);
- DEAD (cont);
CACHE_REGISTER ();
program = SCM_FRAME_PROGRAM (fp);
CACHE_PROGRAM ();
SCM_FRAME_MV_RETURN_ADDRESS (fp),
0);
cont = scm_i_make_continuation (&first, vm, vm_cont);
- DEAD (vm_cont);
if (first)
{
PUSH (proc);
- DEAD (proc);
PUSH (cont);
- DEAD (cont);
nargs = 1;
goto vm_tail_call;
}
else
{
- DEAD (proc);
- DEAD (cont);
/* Otherwise, cache regs and NEXT, as above. Invoking the continuation
does a return from the frame, either to the RA or
MVRA. */
sp = SCM_FRAME_LOWER_ADDRESS (fp);
ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
- COMPILER_BARRIER;
#ifdef VM_ENABLE_STACK_NULLING
NULLSTACK (old_sp - sp);
/* Set return value (sp is already pushed) */
*sp = ret;
-
- DEAD (ret);
}
/* Restore the last program */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
ip = SCM_FRAME_MV_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
- COMPILER_BARRIER;
-
+
/* Push return values, and the number of values */
for (i = 0; i < nvalues; i++)
*++sp = vals[i+1];
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
- COMPILER_BARRIER;
-
+
/* Push first value */
*++sp = vals[1];
NULLSTACK (vals + nvalues - sp);
}
else
- goto vm_error_no_values;
+ {
+ SYNC_ALL ();
+ vm_error_no_values ();
+ }
/* Restore the last program */
program = SCM_FRAME_PROGRAM (fp);
l = SCM_CDR (l);
nvalues++;
}
- if (SCM_UNLIKELY (!SCM_NULL_OR_NIL_P (l))) {
- finish_args = scm_list_1 (l);
- goto vm_error_improper_list;
- }
+ VM_ASSERT (SCM_NULL_OR_NIL_P (l), vm_error_improper_list (l));
- DEAD (l);
goto vm_return_values;
}
SCM n;
POP (n);
nvalues = scm_to_int (n);
- DEAD (n);
ASSERT (nvalues >= 0);
goto vm_return_values;
}
int nbinds, rest;
POP (x);
nvalues = scm_to_int (x);
- DEAD (x);
nbinds = FETCH ();
rest = FETCH ();
if (rest)
nbinds--;
- if (nvalues < nbinds)
- goto vm_error_not_enough_values;
+ VM_ASSERT (nvalues >= nbinds, vm_error_not_enough_values ());
if (rest)
POP_LIST (nvalues - nbinds);
POP (val);
SYNC_BEFORE_GC ();
LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val)));
- DEAD (val);
NEXT;
}
SCM v = LOCAL_REF (FETCH ());
ASSERT_BOUND_VARIABLE (v);
PUSH (VARIABLE_REF (v));
- DEAD (v);
NEXT;
}
POP (val);
ASSERT_VARIABLE (v);
VARIABLE_SET (v, val);
- DEAD (v);
- DEAD (val);
NEXT;
}
v = FREE_VARIABLE_REF (idx);
ASSERT_BOUND_VARIABLE (v);
PUSH (VARIABLE_REF (v));
- DEAD (v);
NEXT;
}
v = FREE_VARIABLE_REF (idx);
ASSERT_BOUND_VARIABLE (v);
VARIABLE_SET (v, val);
- DEAD (v);
- DEAD (val);
NEXT;
}
sp[-len] = closure;
for (n = 0; n < len; n++)
SCM_PROGRAM_FREE_VARIABLE_SET (closure, n, sp[-len + 1 + n]);
- DEAD (closure);
DROPN (len);
NEXT;
}
len = SCM_PROGRAM_NUM_FREE_VARIABLES (x);
for (n = 0; n < len; n++)
SCM_PROGRAM_FREE_VARIABLE_SET (x, n, sp[-len + 1 + n]);
- DEAD (x);
DROPN (len);
NEXT;
}
SCM sym, val;
POP2 (sym, val);
SYNC_REGISTER ();
- VARIABLE_SET (scm_sym2var (sym, scm_current_module_lookup_closure (),
- SCM_BOOL_T),
- val);
- DEAD (sym);
- DEAD (val);
+ scm_define (sym, val);
NEXT;
}
vm_engine that can be assigned *has* been assigned. So we need to pull
all our state back from the ip/fp/sp.
*/
- DEAD (k);
- DEAD (prompt);
CACHE_REGISTER ();
program = SCM_FRAME_PROGRAM (fp);
CACHE_PROGRAM ();
NEXT;
}
- DEAD (k);
- DEAD (prompt);
-
/* Otherwise setjmp returned for the first time, so we go to execute the
prompt's body. */
NEXT;
/* Push wind and unwind procedures onto the dynamic stack. Note that neither
are actually called; the compiler should emit calls to wind and unwind for
the normal dynamic-wind control flow. */
- if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (wind))))
- {
- finish_args = wind;
- goto vm_error_not_a_thunk;
- }
- if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (unwind))))
- {
- finish_args = unwind;
- goto vm_error_not_a_thunk;
- }
+ VM_ASSERT (scm_to_bool (scm_thunk_p (wind)),
+ vm_error_not_a_thunk ("dynamic-wind", wind));
+ VM_ASSERT (scm_to_bool (scm_thunk_p (unwind)),
+ vm_error_not_a_thunk ("dynamic-wind", unwind));
scm_i_set_dynwinds (scm_cons (scm_cons (wind, unwind), scm_i_dynwinds ()));
- DEAD (wind);
- DEAD (unwind);
NEXT;
}
{
unsigned n = FETCH ();
SYNC_REGISTER ();
- if (sp - n - 2 <= SCM_FRAME_UPPER_ADDRESS (fp))
- goto vm_error_stack_underflow;
+ PRE_CHECK_UNDERFLOW (n + 2);
vm_abort (vm, n, vm_cookie);
/* vm_abort should not return */
abort ();
scm_i_swap_with_fluids (wf, current_thread->dynamic_state);
scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
- DEAD (wf);
NEXT;
}
wf = scm_car (scm_i_dynwinds ());
scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
scm_i_swap_with_fluids (wf, current_thread->dynamic_state);
- DEAD (wf);
NEXT;
}
|| ((num = SCM_I_FLUID_NUM (*sp)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
{
/* Punt dynstate expansion and error handling to the C proc. */
- DEAD (fluids);
SYNC_REGISTER ();
*sp = scm_fluid_ref (*sp);
}
else
{
SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
- DEAD (fluids);
if (scm_is_eq (val, SCM_UNDEFINED))
val = SCM_I_FLUID_DEFAULT (*sp);
- if (SCM_UNLIKELY (scm_is_eq (val, SCM_UNDEFINED)))
- {
- finish_args = *sp;
- goto vm_error_unbound_fluid;
- }
+ VM_ASSERT (!scm_is_eq (val, SCM_UNDEFINED),
+ vm_error_unbound_fluid (program, *sp));
*sp = val;
}
}
else
SCM_SIMPLE_VECTOR_SET (fluids, num, val);
- DEAD (fluids);
- DEAD (fluid);
- DEAD (val);
+
NEXT;
}
/* nargs = n & 0x7, nlocs = nargs + (n >> 3) */
n = FETCH ();
- if (SCM_UNLIKELY (sp - (fp - 1) != (n & 0x7)))
- goto vm_error_wrong_num_args;
+ VM_ASSERT (sp - (fp - 1) == (n & 0x7),
+ vm_error_wrong_num_args (program));
old_sp = sp;
sp += (n >> 3);
NEXT;
}
-#undef COMPILER_BARRIER
+/* Like bind-optionals/shuffle, but if there are too many positional
+ arguments, jumps to the next case-lambda clause. */
+VM_DEFINE_INSTRUCTION (94, bind_optionals_shuffle_or_br, "bind-optionals/shuffle-or-br", 9, -1, -1)
+{
+ SCM *walk;
+ scm_t_ptrdiff nreq, nreq_and_opt, ntotal;
+ scm_t_int32 offset;
+ nreq = FETCH () << 8;
+ nreq += FETCH ();
+ nreq_and_opt = FETCH () << 8;
+ nreq_and_opt += FETCH ();
+ ntotal = FETCH () << 8;
+ ntotal += FETCH ();
+ FETCH_OFFSET (offset);
+
+ /* look in optionals for first keyword or last positional */
+ /* starting after the last required positional arg */
+ walk = fp + nreq;
+ while (/* while we have args */
+ walk <= sp
+ /* and we still have positionals to fill */
+ && walk - fp < nreq_and_opt
+ /* and we haven't reached a keyword yet */
+ && !scm_is_keyword (*walk))
+ /* bind this optional arg (by leaving it in place) */
+ walk++;
+ if (/* If we have filled all the positionals */
+ walk - fp == nreq_and_opt
+ /* and there are still more arguments */
+ && walk <= sp
+ /* and the next argument is not a keyword, */
+ && !scm_is_keyword (*walk))
+ {
+ /* Jump to the next case-lambda* clause. */
+ ip += offset;
+ }
+ else
+ {
+ /* Otherwise, finish as in bind-optionals/shuffle: shuffle up,
+ from walk to ntotal */
+ scm_t_ptrdiff nshuf = sp - walk + 1, i;
+ sp = (fp - 1) + ntotal + nshuf;
+ CHECK_OVERFLOW ();
+ for (i = 0; i < nshuf; i++)
+ sp[-i] = walk[nshuf-i-1];
+
+ /* and fill optionals & keyword args with SCM_UNDEFINED */
+ while (walk <= (fp - 1) + ntotal)
+ *walk++ = SCM_UNDEFINED;
+ }
+
+ NEXT;
+}
+
/*
(defun renumber-ops ()
HCoop / bpt / guile.git / blobdiff