[Guile-commits] 02/13: Compile current-module as intrinsic call

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 8918165c4050766dd920b66df9fdad33eb3f42d7
Author: Andy Wingo <address@hidden>
Date:   Wed Jun 27 14:57:51 2018 +0200

    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                        | 17 ++++++++++++-----
 libguile/fluids.h                        |  2 ++
 libguile/intrinsics.c                    |  7 +++++++
 libguile/intrinsics.h                    |  2 ++
 libguile/modules.c                       | 15 +++++++++++----
 libguile/modules.h                       |  1 +
 module/language/cps/reify-primitives.scm |  2 +-
 module/system/vm/assembler.scm           |  6 +++++-
 8 files changed, 41 insertions(+), 11 deletions(-)

diff --git a/libguile/fluids.c b/libguile/fluids.c
index db14f17..f626933 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 1d4f1af..ffcb489 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 cc8cd2b..59192d1 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 02045f3..7a122d9 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 871d87f..751d907 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 dbd5f0c..34edb32 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 e3dfee8..6ec9029 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 650156d..e57e1ba 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)