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.

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
 

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);
 

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",

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

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
 

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);

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)))

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)