diff options
author | Andy Wingo <wingo@pobox.com> | 2018-05-13 10:23:28 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2018-05-14 14:04:54 +0200 |
commit | fb344a25d5fab1714eb1d5ca66bad96fb4834855 (patch) | |
tree | 496697ce8faf53d003e94b52fd45339eac66b810 | |
parent | 16a996f052f381d915288bc4f39dfc4c21930295 (diff) | |
download | guile-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.c | 38 | ||||
-rw-r--r-- | libguile/intrinsics.h | 2 | ||||
-rw-r--r-- | module/language/cps/compile-bytecode.scm | 4 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 7 |
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) |