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

@@ -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;

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,

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))

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)))

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)))

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)