diff --git a/libguile/fluids.c b/libguile/fluids.c index db14f17a8..f62693338 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -370,6 +370,17 @@ fluid_ref (scm_t_dynamic_state *dynamic_state, SCM fluid) return val; } +SCM +scm_i_fluid_ref (scm_thread *thread, SCM fluid) +{ + SCM ret = fluid_ref (thread->dynamic_state, fluid); + + if (SCM_UNBNDP (ret)) + scm_misc_error ("fluid-ref", "unbound fluid: ~S", scm_list_1 (fluid)); + + return ret; +} + SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0, (SCM fluid), "Return the value associated with @var{fluid} in the current\n" @@ -377,12 +388,8 @@ SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0, "its default value.") #define FUNC_NAME s_scm_fluid_ref { - SCM ret; SCM_VALIDATE_FLUID (1, fluid); - ret = fluid_ref (SCM_I_CURRENT_THREAD->dynamic_state, fluid); - if (SCM_UNBNDP (ret)) - scm_misc_error ("fluid-ref", "unbound fluid: ~S", scm_list_1 (fluid)); - return ret; + return scm_i_fluid_ref (SCM_I_CURRENT_THREAD, fluid); } #undef FUNC_NAME diff --git a/libguile/fluids.h b/libguile/fluids.h index 1d4f1afd5..ffcb48931 100644 --- a/libguile/fluids.h +++ b/libguile/fluids.h @@ -66,6 +66,8 @@ SCM_API SCM scm_fluid_set_x (SCM fluid, SCM value); SCM_API SCM scm_fluid_unset_x (SCM fluid); SCM_API SCM scm_fluid_bound_p (SCM fluid); +SCM_INTERNAL SCM scm_i_fluid_ref (scm_thread *thread, SCM fluid); + SCM_INTERNAL void scm_swap_fluid (SCM fluid, SCM value_box, scm_t_dynamic_state *dynamic_state); diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c index cc8cd2b1e..59192d1ea 100644 --- a/libguile/intrinsics.c +++ b/libguile/intrinsics.c @@ -340,6 +340,12 @@ allocate_words (scm_thread *thread, uint64_t n) return SCM_PACK_POINTER (scm_inline_gc_malloc_words (thread, n)); } +static SCM +current_module (scm_thread *thread) +{ + return scm_i_current_module (thread); +} + void scm_bootstrap_intrinsics (void) @@ -394,6 +400,7 @@ scm_bootstrap_intrinsics (void) scm_vm_intrinsics.error_not_enough_values = error_not_enough_values; scm_vm_intrinsics.error_wrong_number_of_values = error_wrong_number_of_values; scm_vm_intrinsics.allocate_words = allocate_words; + scm_vm_intrinsics.current_module = current_module; scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, "scm_init_intrinsics", diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h index 02045f3d5..7a122d983 100644 --- a/libguile/intrinsics.h +++ b/libguile/intrinsics.h @@ -63,6 +63,7 @@ typedef void (*scm_t_noreturn_intrinsic) (void) SCM_NORETURN; typedef void (*scm_t_scm_noreturn_intrinsic) (SCM) SCM_NORETURN; typedef void (*scm_t_u32_noreturn_intrinsic) (uint32_t) SCM_NORETURN; typedef SCM (*scm_t_scm_from_thread_u64_intrinsic) (scm_thread*, uint64_t); +typedef SCM (*scm_t_scm_from_thread_intrinsic) (scm_thread*); #define SCM_FOR_ALL_VM_INTRINSICS(M) \ M(scm_from_scm_scm, add, "add", ADD) \ @@ -127,6 +128,7 @@ typedef SCM (*scm_t_scm_from_thread_u64_intrinsic) (scm_thread*, uint64_t); 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) \ M(scm_from_thread_u64, allocate_words, "allocate-words", ALLOCATE_WORDS) \ + M(scm_from_thread, current_module, "current-module", CURRENT_MODULE) \ /* Add new intrinsics here; also update scm_bootstrap_intrinsics. */ enum scm_vm_intrinsic diff --git a/libguile/modules.c b/libguile/modules.c index 871d87f00..751d9070c 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -38,6 +38,7 @@ #include "smob.h" #include "struct.h" #include "symbols.h" +#include "threads.h" #include "variable.h" #include "vectors.h" @@ -81,15 +82,21 @@ scm_the_root_module (void) return SCM_BOOL_F; } +SCM +scm_i_current_module (scm_thread *thread) +{ + if (scm_module_system_booted_p) + return scm_i_fluid_ref (thread, the_module); + else + return SCM_BOOL_F; +} + SCM_DEFINE (scm_current_module, "current-module", 0, 0, 0, (), "Return the current module.") #define FUNC_NAME s_scm_current_module { - if (scm_module_system_booted_p) - return scm_fluid_ref (the_module); - else - return SCM_BOOL_F; + return scm_i_current_module (SCM_I_CURRENT_THREAD); } #undef FUNC_NAME diff --git a/libguile/modules.h b/libguile/modules.h index dbd5f0c86..34edb328d 100644 --- a/libguile/modules.h +++ b/libguile/modules.h @@ -65,6 +65,7 @@ SCM_API scm_t_bits scm_module_tag; SCM_API SCM scm_current_module (void); +SCM_INTERNAL SCM scm_i_current_module (scm_thread *thread); SCM_API SCM scm_the_root_module (void); SCM_API SCM scm_interaction_environment (void); SCM_API SCM scm_set_current_module (SCM module); diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index e3dfee87f..6ec90299e 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -331,7 +331,7 @@ push-dynamic-state pop-dynamic-state lsh rsh lsh/immediate rsh/immediate cache-ref cache-set! - resolve-module lookup define!)) + resolve-module lookup define! current-module)) (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 650156d58..e57e1bacd 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -227,6 +227,7 @@ emit-resolve-module emit-lookup emit-define! + emit-current-module emit-cache-ref emit-cache-set! @@ -250,7 +251,6 @@ emit-bind-kwargs emit-bind-rest emit-load-label - emit-current-module emit-resolve emit-prompt emit-current-thread @@ -1336,6 +1336,9 @@ returned instead." (define-syntax-rule (define-scm<-scm-bool-intrinsic name) (define-macro-assembler (name asm dst a b) (emit-call-scm<-scm-uimm asm dst a (if b 1 0) (intrinsic-name->index 'name)))) +(define-syntax-rule (define-scm<-thread-intrinsic name) + (define-macro-assembler (name asm dst) + (emit-call-scm<-thread asm dst (intrinsic-name->index 'name)))) (define-scm<-scm-scm-intrinsic add) (define-scm<-scm-uimm-intrinsic add/immediate) @@ -1376,6 +1379,7 @@ returned instead." (define-scm<-scm-bool-intrinsic resolve-module) (define-scm<-scm-scm-intrinsic lookup) (define-scm<-scm-scm-intrinsic define!) +(define-scm<-thread-intrinsic current-module) (define-macro-assembler (begin-program asm label properties) (emit-label asm label)