Simplify module variable lookup slow-path

* libguile/intrinsics.h:
* libguile/intrinsics.c (lookup_bound_public, lookup_bound_private): Two
new intrinsics.
(scm_bootstrap_intrinsics): Wire them up.
* libguile/jit.c (compile_call_scm_from_scmn_scmn):
(compile_call_scm_from_scmn_scmn_slow):
(COMPILE_X8_S24__N32__N32__C32): Add JIT support for new instruction
kind.
* libguile/vm-engine.c (call-scm<-scmn-scmn): New instruction, takes
arguments as non-immediate offsets, to avoid needless loads and register
pressure.
* module/language/cps/effects-analysis.scm: Add cases for new
primcalls.
* module/language/cps/compile-bytecode.scm (compile-function): Add new
primcalls.
* module/language/cps/reify-primitives.scm (cached-module-box): If the
variable is bound, call lookup-bound-public / lookup-bound-private as
appropriate instead of separately resolving the module, name, and doing
the bound check.
* module/language/tree-il/compile-bytecode.scm (emit-cached-module-box):
Use new instructions.
* module/system/vm/assembler.scm (define-scm<-scmn-scmn-intrinsic):
(lookup-bound-public, lookup-bound-private): Add assembler support.

9 files changed, 152 insertions, 13 deletions

diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c
index 92b587cfe..10f897a0e 100644
--- a/libguile/intrinsics.c
+++ b/libguile/intrinsics.c
@@ -1,4 +1,4 @@
-/* Copyright 2018-2020
+/* Copyright 2018-2021
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -368,6 +368,23 @@ lookup_bound (SCM module, SCM name)
   return var;
 }
 
+/* lookup-bound-public and lookup-bound-private take the name as a
+   string instead of a symbol in order to reduce relocations at program
+   startup.  */
+static SCM
+lookup_bound_public (SCM module, SCM name)
+{
+  return lookup_bound (resolve_module (module, 1),
+                       scm_string_to_symbol (name));
+}
+
+static SCM
+lookup_bound_private (SCM module, SCM name)
+{
+  return lookup_bound (resolve_module (module, 0),
+                       scm_string_to_symbol (name));
+}
+
 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;
@@ -601,6 +618,8 @@ scm_bootstrap_intrinsics (void)
   scm_vm_intrinsics.module_variable = module_variable;
   scm_vm_intrinsics.lookup = lookup;
   scm_vm_intrinsics.lookup_bound = lookup_bound;
+  scm_vm_intrinsics.lookup_bound_public = lookup_bound_public;
+  scm_vm_intrinsics.lookup_bound_private = lookup_bound_private;
   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 d8b927c4b..936e06d84 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -1,4 +1,4 @@
-/* Copyright 2018-2020
+/* Copyright 2018-2021
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -34,6 +34,7 @@ typedef SCM (*scm_t_scm_from_scm_uimm_intrinsic) (SCM, uint8_t);
 typedef void (*scm_t_scm_sz_u32_intrinsic) (SCM, size_t, uint32_t);
 typedef SCM (*scm_t_scm_from_scm_intrinsic) (SCM);
 typedef double (*scm_t_f64_from_scm_intrinsic) (SCM);
+typedef SCM (*scm_t_scm_from_scmn_scmn_intrinsic) (SCM, SCM);
 
 /* If we don't have 64-bit registers, the intrinsics will take and
    return 64-bit values by reference.  */
@@ -214,6 +215,8 @@ typedef void (*scm_t_scm_uimm_scm_intrinsic) (SCM, uint8_t, SCM);
   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) \
+  M(scm_from_scmn_scmn, lookup_bound_public, "lookup-bound-public", LOOKUP_BOUND_PUBLIC) \
+  M(scm_from_scmn_scmn, lookup_bound_private, "lookup-bound-private", LOOKUP_BOUND_PRIVATE) \
   /* Add new intrinsics here; also update scm_bootstrap_intrinsics.  */
 
 /* Intrinsics prefixed with $ are meant to reduce bytecode size,
diff --git a/libguile/jit.c b/libguile/jit.c
index 45208be30..8420829b4 100644
--- a/libguile/jit.c
+++ b/libguile/jit.c
@@ -5217,6 +5217,26 @@ compile_s64_to_f64_slow (scm_jit_state *j, uint16_t dst, uint16_t src)
 {
 }
 
+static void
+compile_call_scm_from_scmn_scmn (scm_jit_state *j, uint32_t dst,
+                                 void *a, void *b, uint32_t idx)
+{
+  void *intrinsic = ((void **) &scm_vm_intrinsics)[idx];
+  jit_operand_t op_a = jit_operand_imm (JIT_OPERAND_ABI_POINTER, (uintptr_t)a);
+  jit_operand_t op_b = jit_operand_imm (JIT_OPERAND_ABI_POINTER, (uintptr_t)b);
+
+  emit_store_current_ip (j, T2);
+  emit_call_2 (j, intrinsic, op_a, op_b);
+  emit_retval (j, T0);
+  emit_reload_sp (j);
+  emit_sp_set_scm (j, dst, T0);
+}
+static void
+compile_call_scm_from_scmn_scmn_slow (scm_jit_state *j, uint32_t dst,
+                                      void *a, void *b, uint32_t idx)
+{
+}
+
 
 #define UNPACK_8_8_8(op,a,b,c)            \
   do                                      \
@@ -5575,6 +5595,16 @@ compile_s64_to_f64_slow (scm_jit_state *j, uint16_t dst, uint16_t src)
     comp (j, a, b, c, d, e);                                            \
   }
 
+#define COMPILE_X8_S24__N32__N32__C32(j, comp)                          \
+  {                                                                     \
+    uint32_t a;                                                         \
+    UNPACK_24 (j->ip[0], a);                                            \
+    int32_t b = j->ip[1];                                               \
+    int32_t c = j->ip[2];                                               \
+    uint32_t d = j->ip[3];                                              \
+    comp (j, a, j->ip + b, j->ip + c, d);                               \
+  }
+
 static uintptr_t opcodes_seen[256 / (SCM_SIZEOF_UINTPTR_T * 8)];
 
 static uintptr_t
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index bf646847c..510563ce4 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1,4 +1,4 @@
-/* Copyright 2001,2009-2015,2017-2020
+/* Copyright 2001,2009-2015,2017-2021
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -3437,7 +3437,47 @@ VM_NAME (scm_thread *thread)
       NEXT (1);
     }
 
-  VM_DEFINE_OP (166, unused_166, NULL, NOP)
+  /* call-scm<-scmn-scmn dst:24 a:32 b:32 idx:32
+   *
+   * Call the SCM-returning instrinsic with index IDX, passing the SCM
+   * values A and B as arguments.  A and B are non-immediates, located
+   * at a constant offset from the instruction.  Place the SCM result in
+   * DST.
+   */
+  VM_DEFINE_OP (166, call_scm_from_scmn_scmn, "call-scm<-scmn-scmn", DOP4 (X8_S24, N32, N32, C32))
+    {
+      uint32_t dst;
+      SCM a, b;
+      scm_t_scm_from_scmn_scmn_intrinsic intrinsic;
+
+      UNPACK_24 (op, dst);
+
+      {
+        int32_t offset = ip[1];
+        uint32_t* loc = ip + offset;
+        scm_t_bits unpacked = (scm_t_bits) loc;
+        VM_ASSERT (!(unpacked & 0x7), abort());
+        a = SCM_PACK (unpacked);
+      }
+
+      {
+        int32_t offset = ip[2];
+        uint32_t* loc = ip + offset;
+        scm_t_bits unpacked = (scm_t_bits) loc;
+        VM_ASSERT (!(unpacked & 0x7), abort());
+        b = SCM_PACK (unpacked);
+      }
+
+      intrinsic = intrinsics[ip[3]];
+
+      SYNC_IP ();
+      SCM res = intrinsic (a, b);
+      CACHE_SP ();
+      SP_SET (dst, res);
+
+      NEXT (4);
+    }
+
   VM_DEFINE_OP (167, unused_167, NULL, NOP)
   VM_DEFINE_OP (168, unused_168, NULL, NOP)
   VM_DEFINE_OP (169, unused_169, NULL, NOP)
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 7f4f97709..a2c951dc9 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -195,6 +195,12 @@
         (($ $primcall 'lookup-bound #f (mod name))
          (emit-lookup-bound asm (from-sp dst) (from-sp (slot mod))
                             (from-sp (slot name))))
+        (($ $primcall 'lookup-bound-public (mod name) ())
+         (let ((name (symbol->string name)))
+           (emit-lookup-bound-public asm (from-sp dst) mod name)))
+        (($ $primcall 'lookup-bound-private (mod name) ())
+         (let ((name (symbol->string name)))
+           (emit-lookup-bound-private asm (from-sp dst) mod 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 7315fce73..365c280c1 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -1,6 +1,6 @@
 ;;; Effects analysis on CPS
 
-;; Copyright (C) 2011-2015,2017-2020 Free Software Foundation, Inc.
+;; Copyright (C) 2011-2015,2017-2021 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -485,6 +485,8 @@ the LABELS that are clobbered by the effects of LABEL."
   ((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)
+  ((lookup-bound-public)                                       &type-check)
+  ((lookup-bound-private)                                      &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 710ad6ff0..d0441ff5f 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -223,6 +223,28 @@
 
 (define-ephemeral (cached-module-box cps k src param)
   (match param
+    ((module name public? #t)
+     (let ((cache-key param))
+       (with-cps cps
+         (letv cached var)
+         (letk k* ($kargs () () ($continue k src ($values (var)))))
+         (letk kcache ($kargs ('var) (var)
+                        ($continue k* src
+                          ($primcall 'cache-set! cache-key (var)))))
+         (letk kinit ($kargs () ()
+                       ($continue kcache src
+                         ($primcall (if public?
+                                        'lookup-bound-public
+                                        'lookup-bound-private)
+                                    (list module name) ()))))
+         (letk kok ($kargs () ()
+                     ($continue k src ($values (cached)))))
+         (letk ktest
+               ($kargs ('cached) (cached)
+                 ($branch kinit kok src 'heap-object? #f (cached))))
+         (build-term
+           ($continue ktest src
+             ($primcall 'cache-ref cache-key ()))))))
     ((module name public? bound?)
      (let ((cache-key param))
        (with-cps cps
@@ -335,7 +357,8 @@
       lsh rsh lsh/immediate rsh/immediate
       cache-ref cache-set!
       current-module resolve-module
-      module-variable lookup lookup-bound define!))
+      module-variable define!
+      lookup lookup-bound lookup-bound-public lookup-bound-private))
   (let ((table (make-hash-table)))
     (for-each
      (match-lambda ((inst . _) (hashq-set! table inst #t)))
diff --git a/module/language/tree-il/compile-bytecode.scm b/module/language/tree-il/compile-bytecode.scm
index 419f5c8d3..c495d2ae6 100644
--- a/module/language/tree-il/compile-bytecode.scm
+++ b/module/language/tree-il/compile-bytecode.scm
@@ -1,6 +1,6 @@
 ;;; Lightweight compiler directly from Tree-IL to bytecode
 
-;; Copyright (C) 2020 Free Software Foundation, Inc.
+;; Copyright (C) 2020, 2021 Free Software Foundation, Inc.
 
 ;;; This library is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Lesser General Public License as published by
@@ -75,12 +75,17 @@
   (emit-cache-ref asm dst key)
   (emit-heap-object? asm dst)
   (emit-je asm cached)
-  (emit-load-constant asm dst mod)
-  (emit-resolve-module asm dst dst public?)
-  (emit-load-constant asm tmp name)
-  (if bound?
-      (emit-lookup-bound asm dst dst tmp)
-      (emit-lookup asm dst dst tmp))
+  (cond
+   (bound?
+    (let ((name (symbol->string name)))
+      (if public?
+          (emit-lookup-bound-public asm dst mod name)
+          (emit-lookup-bound-private asm dst mod name))))
+   (else
+    (emit-load-constant asm dst mod)
+    (emit-resolve-module asm dst dst public?)
+    (emit-load-constant asm tmp name)
+    (emit-lookup asm dst dst tmp)))
   (emit-cache-set! asm key dst)
   (emit-label asm cached))
 (define (emit-cached-toplevel-box asm dst scope name bound? tmp)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index c94cec3af..8a6ca4e47 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -254,6 +254,8 @@
             emit-module-variable
             emit-lookup
             emit-lookup-bound
+            emit-lookup-bound-public
+            emit-lookup-bound-private
             emit-define!
             emit-current-module
 
@@ -1495,6 +1497,13 @@ returned instead."
 (define-syntax-rule (define-scm-scm-scm-intrinsic name)
   (define-macro-assembler (name asm a b c)
     (emit-call-scm-scm-scm asm a b c (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-scmn-scmn-intrinsic name)
+  (define-macro-assembler (name asm dst a b)
+    (unless (statically-allocatable? a) (error "not statically allocatable" a))
+    (unless (statically-allocatable? b) (error "not statically allocatable" b))
+    (let ((a (intern-constant asm a))
+          (b (intern-constant asm b)))
+      (emit-call-scm<-scmn-scmn asm dst a b (intrinsic-name->index 'name)))))
 
 (define-scm<-scm-scm-intrinsic add)
 (define-scm<-scm-uimm-intrinsic add/immediate)
@@ -1559,6 +1568,8 @@ returned instead."
 (define-scm<-scm-scm-intrinsic module-variable)
 (define-scm<-scm-scm-intrinsic lookup)
 (define-scm<-scm-scm-intrinsic lookup-bound)
+(define-scm<-scmn-scmn-intrinsic lookup-bound-public)
+(define-scm<-scmn-scmn-intrinsic lookup-bound-private)
 (define-scm<-scm-scm-intrinsic define!)
 (define-scm<-thread-intrinsic current-module)