summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2018-05-13 10:23:28 +0200
committerAndy Wingo <wingo@pobox.com>2018-05-14 14:04:54 +0200
commitfb344a25d5fab1714eb1d5ca66bad96fb4834855 (patch)
tree496697ce8faf53d003e94b52fd45339eac66b810
parent16a996f052f381d915288bc4f39dfc4c21930295 (diff)
downloadguile-fb344a25d5fab1714eb1d5ca66bad96fb4834855.tar.gz
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.
-rw-r--r--libguile/intrinsics.c38
-rw-r--r--libguile/intrinsics.h2
-rw-r--r--module/language/cps/compile-bytecode.scm4
-rw-r--r--module/system/vm/assembler.scm7
4 files changed, 51 insertions, 0 deletions
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)