summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2018-06-27 14:57:51 +0200
committerAndy Wingo <wingo@pobox.com>2018-06-27 14:57:51 +0200
commit8918165c4050766dd920b66df9fdad33eb3f42d7 (patch)
tree43bb1cb2409c86369e872c6029441599e8ac306b
parent0faa4144d14723c2774af88c146617e9ef2e066b (diff)
downloadguile-8918165c4050766dd920b66df9fdad33eb3f42d7.tar.gz
Compile current-module as intrinsic call
* libguile/fluids.c (scm_i_fluid_ref): New internal function. (scm_fluid_ref): Use scm_i_fluid_ref. * libguile/intrinsics.h: * libguile/intrinsics.c (current_module): New intrinsic. * libguile/modules.c (scm_i_current_module): New internal function. (scm_current_module): Use new internal function. * module/language/cps/reify-primitives.scm (compute-known-primitives): Add current-module as an intrinsic primitive. * module/system/vm/assembler.scm (define-scm<-thread-intrinsic): (current-module): Arrange to compile to intrinsic call.
-rw-r--r--libguile/fluids.c17
-rw-r--r--libguile/fluids.h2
-rw-r--r--libguile/intrinsics.c7
-rw-r--r--libguile/intrinsics.h2
-rw-r--r--libguile/modules.c15
-rw-r--r--libguile/modules.h1
-rw-r--r--module/language/cps/reify-primitives.scm2
-rw-r--r--module/system/vm/assembler.scm6
8 files changed, 41 insertions, 11 deletions
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)