From fb344a25d5fab1714eb1d5ca66bad96fb4834855 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sun, 13 May 2018 10:23:28 +0200
Subject: [PATCH] Add intrinsics for module operations

* libguile/intrinsics.c (scm_bootstrap_intrinsics):
* libguile/intrinsics.h (SCM_FOR_ALL_VM_INTRINSICS):
* module/system/vm/assembler.scm (resolve-module, lookup): New intrinsics.
* module/language/cps/compile-bytecode: Add cases for primcalls
  corresponding to new intrinsics.
---
 libguile/intrinsics.c                    | 38 ++++++++++++++++++++++++
 libguile/intrinsics.h                    |  2 ++
 module/language/cps/compile-bytecode.scm |  4 +++
 module/system/vm/assembler.scm           |  7 +++++
 4 files changed, 51 insertions(+)

diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c
index c361e4626..64f8d7f32 100644
--- a/libguile/intrinsics.c
+++ b/libguile/intrinsics.c
@@ -220,6 +220,42 @@ numerically_equal_p (SCM a, SCM b)
   return scm_is_true (scm_num_eq_p (a, b));
 }
 
+static SCM
+resolve_module (SCM name, scm_t_uint8 public_p)
+{
+  SCM mod;
+
+  if (!scm_module_system_booted_p)
+    return SCM_BOOL_F;
+
+  mod = scm_maybe_resolve_module (name);
+  if (scm_is_false (mod))
+    scm_misc_error (NULL, "Module named ~s does not exist",
+                    scm_list_1 (name));
+
+  if (public_p)
+    {
+      mod = scm_module_public_interface (mod);
+
+      if (scm_is_false (mod))
+        scm_misc_error (NULL, "Module named ~s has no public interface",
+                        scm_list_1 (name));
+    }
+
+  return mod;
+}
+
+static SCM
+lookup (SCM module, SCM name)
+{
+  /* If MODULE was captured before modules were booted, use the root
+     module.  Not so nice, but hey...  */
+  if (scm_is_false (module))
+    module = scm_the_root_module ();
+
+  return scm_module_variable (module, name);
+}
+
 void
 scm_bootstrap_intrinsics (void)
 {
@@ -262,6 +298,8 @@ scm_bootstrap_intrinsics (void)
   scm_vm_intrinsics.heap_numbers_equal_p = scm_i_heap_numbers_equal_p;
   scm_vm_intrinsics.less_p = less_p;
   scm_vm_intrinsics.numerically_equal_p = numerically_equal_p;
+  scm_vm_intrinsics.resolve_module = resolve_module;
+  scm_vm_intrinsics.lookup = lookup;
 
   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                             "scm_init_intrinsics",
diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index 9d8010a5e..9d5bc7d3c 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -82,6 +82,8 @@ typedef enum scm_compare (*scm_t_compare_from_scm_scm_intrinsic) (SCM, SCM);
   M(bool_from_scm_scm, heap_numbers_equal_p, "heap-numbers-equal?", HEAP_NUMBERS_EQUAL_P) \
   M(compare_from_scm_scm, less_p, "<?", LESS_P) \
   M(bool_from_scm_scm, numerically_equal_p, "=?", NUMERICALLY_EQUAL_P) \
+  M(scm_from_scm_uimm, resolve_module, "resolve-module", RESOLVE_MODULE) \
+  M(scm_from_scm_scm, lookup, "lookup", LOOKUP) \
   /* Add new intrinsics here; also update scm_bootstrap_intrinsics.  */
 
 enum scm_vm_intrinsic
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 88da19421..426942c21 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -175,6 +175,10 @@
         (($ $primcall 'tail-pointer-ref/immediate (annotation . idx) (obj))
          (emit-tail-pointer-ref/immediate asm (from-sp dst) (from-sp (slot obj))
                                           idx))
+        (($ $primcall 'resolve-module public? (name))
+         (emit-resolve-module asm (from-sp dst) (from-sp (slot name)) public?))
+        (($ $primcall 'lookup #f (mod name))
+         (emit-lookup asm (from-sp dst) (from-sp (slot mod)) (from-sp (slot name))))
         (($ $primcall 'add/immediate y (x))
          (emit-add/immediate asm (from-sp dst) (from-sp (slot x)) y))
         (($ $primcall 'sub/immediate y (x))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 59434295e..56644fdf4 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -224,6 +224,8 @@
             emit-rsh
             emit-lsh/immediate
             emit-rsh/immediate
+            emit-resolve-module
+            emit-lookup
 
             emit-call
             emit-call-label
@@ -1336,6 +1338,9 @@ returned instead."
 (define-syntax-rule (define-scm<-scm-u64-intrinsic name)
   (define-macro-assembler (name asm dst a b)
     (emit-call-scm<-scm-u64 asm dst a b (intrinsic-name->index 'name))))
+(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-scm<-scm-scm-intrinsic add)
 (define-scm<-scm-uimm-intrinsic add/immediate)
@@ -1373,6 +1378,8 @@ returned instead."
 (define-scm<-scm-u64-intrinsic rsh)
 (define-scm<-scm-uimm-intrinsic lsh/immediate)
 (define-scm<-scm-uimm-intrinsic rsh/immediate)
+(define-scm<-scm-bool-intrinsic resolve-module)
+(define-scm<-scm-scm-intrinsic lookup)
 
 (define-macro-assembler (begin-program asm label properties)
   (emit-label asm label)