diff options
-rw-r--r-- | libguile/intrinsics.c | 58 | ||||
-rw-r--r-- | libguile/intrinsics.h | 6 | ||||
-rw-r--r-- | libguile/vm-engine.c | 42 | ||||
-rw-r--r-- | module/language/cps/reify-primitives.scm | 4 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 18 |
5 files changed, 85 insertions, 43 deletions
diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c index e32369126..24d82c081 100644 --- a/libguile/intrinsics.c +++ b/libguile/intrinsics.c @@ -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", diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h index b0f6d655a..7b4fb6e4f 100644 --- a/libguile/intrinsics.h +++ b/libguile/intrinsics.h @@ -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 diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 19c263f2f..67fd767f3 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -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; diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index fb5858c0f..f3da8ef8c 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -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))) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 973179ad4..7144a9e71 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -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) |