[Guile-commits] 02/04: Add new lookup, lookup-bound intrinsics

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 4274d615cc442bd4dc3696ebfd57fd0c6ac3dd58
Author: Andy Wingo <address@hidden>
AuthorDate: Mon May 11 10:00:30 2020 +0200

    Add new lookup, lookup-bound intrinsics
    
    * libguile/intrinsics.h (SCM_FOR_ALL_VM_INTRINSICS):
    * libguile/intrinsics.c (lookup, lookup_bound):
    * libguile/intrinsics.c (scm_bootstrap_intrinsics): New intrinsics.
    * module/language/cps/reify-primitives.scm (reify-primitives):
    * module/language/cps/effects-analysis.scm (current-module):
    * module/language/cps/compile-bytecode.scm (compile-function):
    * module/system/vm/assembler.scm: Add compiler support.
---
 libguile/intrinsics.c                    | 26 ++++++++++++++++++++++++++
 libguile/intrinsics.h                    |  2 ++
 module/language/cps/compile-bytecode.scm |  6 ++++++
 module/language/cps/effects-analysis.scm |  2 ++
 module/language/cps/reify-primitives.scm |  3 ++-
 module/system/vm/assembler.scm           |  4 ++++
 6 files changed, 42 insertions(+), 1 deletion(-)

diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c
index d23731e..92b587c 100644
--- a/libguile/intrinsics.c
+++ b/libguile/intrinsics.c
@@ -344,6 +344,30 @@ module_variable (SCM module, SCM name)
   return scm_module_variable (module, name);
 }
 
+static SCM
+lookup (SCM module, SCM name)
+{
+  SCM var = module_variable (module, name);
+
+  if (!SCM_VARIABLEP (var))
+    scm_error (scm_from_latin1_symbol ("unbound-variable"), NULL,
+               "Unbound variable: ~S", scm_list_1 (name), SCM_BOOL_F);
+
+  return var;
+}
+
+static SCM
+lookup_bound (SCM module, SCM name)
+{
+  SCM var = lookup (module, name);
+
+  if (SCM_UNBNDP (SCM_VARIABLE_REF (var)))
+    scm_error (scm_from_latin1_symbol ("unbound-variable"), NULL,
+               "Unbound variable: ~S", scm_list_1 (name), SCM_BOOL_F);
+
+  return var;
+}
+
 static void throw_ (SCM key, SCM args) SCM_NORETURN;
 static void throw_with_value (SCM val, SCM key_subr_and_message) SCM_NORETURN;
 static void throw_with_value_and_data (SCM val, SCM key_subr_and_message) 
SCM_NORETURN;
@@ -575,6 +599,8 @@ scm_bootstrap_intrinsics (void)
   scm_vm_intrinsics.numerically_equal_p = numerically_equal_p;
   scm_vm_intrinsics.resolve_module = resolve_module;
   scm_vm_intrinsics.module_variable = module_variable;
+  scm_vm_intrinsics.lookup = lookup;
+  scm_vm_intrinsics.lookup_bound = lookup_bound;
   scm_vm_intrinsics.define_x = scm_module_ensure_local_variable;
   scm_vm_intrinsics.throw_ = throw_;
   scm_vm_intrinsics.throw_with_value = throw_with_value;
diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index c941056..d8b927c 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -212,6 +212,8 @@ typedef void (*scm_t_scm_uimm_scm_intrinsic) (SCM, uint8_t, 
SCM);
   M(scm_scm_scm, struct_set_x, "$struct-set!", STRUCT_SET_X) \
   M(scm_from_scm_uimm, struct_ref_immediate, "$struct-ref/immediate", 
STRUCT_REF_IMMEDIATE) \
   M(scm_uimm_scm, struct_set_x_immediate, "$struct-set!/immediate", 
STRUCT_SET_X_IMMEDIATE) \
+  M(scm_from_scm_scm, lookup, "lookup", LOOKUP) \
+  M(scm_from_scm_scm, lookup_bound, "lookup-bound", LOOKUP_BOUND) \
   /* Add new intrinsics here; also update scm_bootstrap_intrinsics.  */
 
 /* Intrinsics prefixed with $ are meant to reduce bytecode size,
diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index c11ba31..51938a0 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -189,6 +189,12 @@
         (($ $primcall 'module-variable #f (mod name))
          (emit-module-variable asm (from-sp dst) (from-sp (slot mod))
                                (from-sp (slot name))))
+        (($ $primcall 'lookup #f (mod name))
+         (emit-lookup asm (from-sp dst) (from-sp (slot mod))
+                      (from-sp (slot name))))
+        (($ $primcall 'lookup-bound #f (mod name))
+         (emit-lookup-bound 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/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 32bf5b6..59f4191 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -486,6 +486,8 @@ the LABELS that are clobbered by the effects of LABEL."
   ((resolve name)                  (&read-object &module)      &type-check)
   ((resolve-module mod)            (&read-object &module)      &type-check)
   ((module-variable mod name)      (&read-object &module)      &type-check)
+  ((lookup mod name)               (&read-object &module)      &type-check)
+  ((lookup-bound mod name)         (&read-object &module)      &type-check)
   ((cached-toplevel-box)                                       &type-check)
   ((cached-module-box)                                         &type-check)
   ((define! mod name)              (&read-object &module)))
diff --git a/module/language/cps/reify-primitives.scm 
b/module/language/cps/reify-primitives.scm
index 863018c..98cf85d 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -354,7 +354,8 @@
       push-dynamic-state pop-dynamic-state
       lsh rsh lsh/immediate rsh/immediate
       cache-ref cache-set!
-      resolve-module module-variable define! current-module))
+      current-module resolve-module
+      module-variable lookup lookup-bound define!))
   (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 b9b313f..7849e55 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -257,6 +257,8 @@
             emit-rsh/immediate
             emit-resolve-module
             emit-module-variable
+            emit-lookup
+            emit-lookup-bound
             emit-define!
             emit-current-module
 
@@ -1494,6 +1496,8 @@ returned instead."
 (define-scm<-scm-uimm-intrinsic rsh/immediate)
 (define-scm<-scm-bool-intrinsic resolve-module)
 (define-scm<-scm-scm-intrinsic module-variable)
+(define-scm<-scm-scm-intrinsic lookup)
+(define-scm<-scm-scm-intrinsic lookup-bound)
 (define-scm<-scm-scm-intrinsic define!)
 (define-scm<-thread-intrinsic current-module)