mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 13:30:26 +02:00
Intrinsics for dynamic state instructions
* libguile/intrinsics.c (wind, unwind, push_fluid, pop_fluid) (fluid_ref): New intrinsics. (scm_bootstrap_intrinsics): Wire them up. * libguile/intrinsics.h (SCM_FOR_ALL_VM_INTRINSICS): Declare new intrinsics. * libguile/vm-engine.c (wind, unwind, push_fluid, pop_fluid) (fluid_ref): Disable these instructions. * module/language/cps/reify-primitives.scm (compute-known-primitives): Add new intrinsics. * module/system/vm/assembler.scm (wind, unwind, push_fluid, pop_fluid) (fluid_ref): Assemble as intrinsics.
This commit is contained in:
parent
4779a10223
commit
2eb9c755d1
5 changed files with 85 additions and 43 deletions
|
@ -96,6 +96,58 @@ logsub (SCM x, SCM y)
|
|||
return scm_logand (x, scm_lognot (y));
|
||||
}
|
||||
|
||||
static void
|
||||
wind (scm_i_thread *thread, SCM winder, SCM unwinder)
|
||||
{
|
||||
scm_dynstack_push_dynwind (&thread->dynstack, winder, unwinder);
|
||||
}
|
||||
|
||||
static void
|
||||
unwind (scm_i_thread *thread)
|
||||
{
|
||||
scm_dynstack_pop (&thread->dynstack);
|
||||
}
|
||||
|
||||
static void
|
||||
push_fluid (scm_i_thread *thread, SCM fluid, SCM value)
|
||||
{
|
||||
scm_dynstack_push_fluid (&thread->dynstack, fluid, value,
|
||||
thread->dynamic_state);
|
||||
}
|
||||
|
||||
static void
|
||||
pop_fluid (scm_i_thread *thread)
|
||||
{
|
||||
scm_dynstack_unwind_fluid (&thread->dynstack, thread->dynamic_state);
|
||||
}
|
||||
|
||||
static SCM
|
||||
fluid_ref (scm_i_thread *thread, SCM fluid)
|
||||
{
|
||||
struct scm_cache_entry *entry;
|
||||
|
||||
/* If we find FLUID in the cache, then it is indeed a fluid. */
|
||||
entry = scm_cache_lookup (&thread->dynamic_state->cache, fluid);
|
||||
if (SCM_LIKELY (scm_is_eq (SCM_PACK (entry->key), fluid)
|
||||
&& !SCM_UNBNDP (SCM_PACK (entry->value))))
|
||||
return SCM_PACK (entry->value);
|
||||
|
||||
return scm_fluid_ref (fluid);
|
||||
}
|
||||
|
||||
static void
|
||||
fluid_set_x (scm_i_thread *thread, SCM fluid, SCM value)
|
||||
{
|
||||
struct scm_cache_entry *entry;
|
||||
|
||||
/* If we find FLUID in the cache, then it is indeed a fluid. */
|
||||
entry = scm_cache_lookup (&thread->dynamic_state->cache, fluid);
|
||||
if (SCM_LIKELY (scm_is_eq (SCM_PACK (entry->key), fluid)))
|
||||
entry->value = SCM_UNPACK (value);
|
||||
else
|
||||
scm_fluid_set_x (fluid, value);
|
||||
}
|
||||
|
||||
void
|
||||
scm_bootstrap_intrinsics (void)
|
||||
{
|
||||
|
@ -123,6 +175,12 @@ scm_bootstrap_intrinsics (void)
|
|||
scm_vm_intrinsics.u64_to_scm = scm_from_uint64;
|
||||
scm_vm_intrinsics.s64_to_scm = scm_from_int64;
|
||||
scm_vm_intrinsics.logsub = logsub;
|
||||
scm_vm_intrinsics.wind = wind;
|
||||
scm_vm_intrinsics.unwind = unwind;
|
||||
scm_vm_intrinsics.push_fluid = push_fluid;
|
||||
scm_vm_intrinsics.pop_fluid = pop_fluid;
|
||||
scm_vm_intrinsics.fluid_ref = fluid_ref;
|
||||
scm_vm_intrinsics.fluid_set_x = fluid_set_x;
|
||||
|
||||
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
|
||||
"scm_init_intrinsics",
|
||||
|
|
|
@ -61,6 +61,12 @@ typedef SCM (*scm_t_scm_from_thread_scm_intrinsic) (scm_i_thread*, SCM);
|
|||
M(scm_from_u64, u64_to_scm, "u64->scm", U64_TO_SCM) \
|
||||
M(scm_from_s64, s64_to_scm, "s64->scm", S64_TO_SCM) \
|
||||
M(scm_from_scm_scm, logsub, "logsub", LOGSUB) \
|
||||
M(thread_scm_scm, wind, "wind", WIND) \
|
||||
M(thread, unwind, "unwind", UNWIND) \
|
||||
M(thread_scm_scm, push_fluid, "push-fluid", PUSH_FLUID) \
|
||||
M(thread, pop_fluid, "pop-fluid", POP_FLUID) \
|
||||
M(scm_from_thread_scm, fluid_ref, "fluid-ref", FLUID_REF) \
|
||||
M(thread_scm_scm, fluid_set_x, "fluid-set!", FLUID_SET_X) \
|
||||
/* Add new intrinsics here; also update scm_bootstrap_intrinsics. */
|
||||
|
||||
enum scm_vm_intrinsic
|
||||
|
|
|
@ -1992,15 +1992,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
|
|||
NEXT (3);
|
||||
}
|
||||
|
||||
/* wind winder:12 unwinder:12
|
||||
*
|
||||
* 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. Also note that
|
||||
* the compiler should have inserted checks that they wind and unwind
|
||||
* procs are thunks, if it could not prove that to be the case.
|
||||
*/
|
||||
VM_DEFINE_OP (70, wind, "wind", OP1 (X8_S12_S12))
|
||||
VM_DEFINE_OP (70, unused_70, NULL, NOP)
|
||||
{
|
||||
scm_t_uint16 winder, unwinder;
|
||||
UNPACK_12_12 (op, winder, unwinder);
|
||||
|
@ -2010,22 +2002,13 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
|
|||
NEXT (1);
|
||||
}
|
||||
|
||||
/* unwind _:24
|
||||
*
|
||||
* A normal exit from the dynamic extent of an expression. Pop the top
|
||||
* entry off of the dynamic stack.
|
||||
*/
|
||||
VM_DEFINE_OP (71, unwind, "unwind", OP1 (X32))
|
||||
VM_DEFINE_OP (71, unused_71, NULL, NOP)
|
||||
{
|
||||
scm_dynstack_pop (&thread->dynstack);
|
||||
NEXT (1);
|
||||
}
|
||||
|
||||
/* push-fluid fluid:12 value:12
|
||||
*
|
||||
* Dynamically bind VALUE to FLUID.
|
||||
*/
|
||||
VM_DEFINE_OP (72, push_fluid, "push-fluid", OP1 (X8_S12_S12))
|
||||
VM_DEFINE_OP (72, unused_72, NULL, NOP)
|
||||
{
|
||||
scm_t_uint32 fluid, value;
|
||||
|
||||
|
@ -2038,12 +2021,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
|
|||
NEXT (1);
|
||||
}
|
||||
|
||||
/* pop-fluid _:24
|
||||
*
|
||||
* Leave the dynamic extent of a with-fluid* expression, restoring the
|
||||
* fluid to its previous value.
|
||||
*/
|
||||
VM_DEFINE_OP (73, pop_fluid, "pop-fluid", OP1 (X32))
|
||||
VM_DEFINE_OP (73, unused_73, NULL, NOP)
|
||||
{
|
||||
/* This function must not allocate. */
|
||||
scm_dynstack_unwind_fluid (&thread->dynstack,
|
||||
|
@ -2051,11 +2029,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
|
|||
NEXT (1);
|
||||
}
|
||||
|
||||
/* fluid-ref dst:12 src:12
|
||||
*
|
||||
* Reference the fluid in SRC, and place the value in DST.
|
||||
*/
|
||||
VM_DEFINE_OP (74, fluid_ref, "fluid-ref", OP1 (X8_S12_S12) | OP_DST)
|
||||
VM_DEFINE_OP (74, unused_74, NULL, NOP)
|
||||
{
|
||||
scm_t_uint16 dst, src;
|
||||
SCM fluid;
|
||||
|
@ -2080,11 +2054,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
|
|||
}
|
||||
}
|
||||
|
||||
/* fluid-set fluid:12 val:12
|
||||
*
|
||||
* Set the value of the fluid in DST to the value in SRC.
|
||||
*/
|
||||
VM_DEFINE_OP (75, fluid_set, "fluid-set!", OP1 (X8_S12_S12))
|
||||
VM_DEFINE_OP (75, unused_75, NULL, NOP)
|
||||
{
|
||||
scm_t_uint16 a, b;
|
||||
SCM fluid, value;
|
||||
|
|
|
@ -235,7 +235,9 @@
|
|||
u64->s64 u64->scm scm->u64 scm->u64/truncate
|
||||
cache-current-module!
|
||||
cached-toplevel-box
|
||||
cached-module-box))
|
||||
cached-module-box
|
||||
wind unwind
|
||||
push-fluid pop-fluid fluid-ref fluid-set!))
|
||||
(let ((table (make-hash-table)))
|
||||
(for-each
|
||||
(match-lambda ((inst . _) (hashq-set! table inst #t)))
|
||||
|
|
|
@ -212,6 +212,12 @@
|
|||
emit-scm->s64
|
||||
emit-u64->scm
|
||||
emit-s64->scm
|
||||
emit-wind
|
||||
emit-unwind
|
||||
emit-push-fluid
|
||||
emit-pop-fluid
|
||||
emit-fluid-ref
|
||||
emit-fluid-set!
|
||||
|
||||
emit-call
|
||||
emit-call-label
|
||||
|
@ -238,15 +244,9 @@
|
|||
emit-toplevel-box
|
||||
emit-module-box
|
||||
emit-prompt
|
||||
emit-wind
|
||||
emit-unwind
|
||||
emit-push-fluid
|
||||
emit-pop-fluid
|
||||
emit-push-dynamic-state
|
||||
emit-pop-dynamic-state
|
||||
emit-current-thread
|
||||
emit-fluid-ref
|
||||
emit-fluid-set!
|
||||
emit-lsh
|
||||
emit-rsh
|
||||
emit-lsh/immediate
|
||||
|
@ -1355,6 +1355,12 @@ returned instead."
|
|||
(define-s64<-scm-intrinsic scm->s64)
|
||||
(define-scm<-u64-intrinsic u64->scm)
|
||||
(define-scm<-s64-intrinsic s64->scm)
|
||||
(define-thread-scm-scm-intrinsic wind)
|
||||
(define-thread-intrinsic unwind)
|
||||
(define-thread-scm-scm-intrinsic push-fluid)
|
||||
(define-thread-intrinsic pop-fluid)
|
||||
(define-scm<-thread-scm-intrinsic fluid-ref)
|
||||
(define-thread-scm-scm-intrinsic fluid-set!)
|
||||
|
||||
(define-macro-assembler (begin-program asm label properties)
|
||||
(emit-label asm label)
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue