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.

4 files changed, 45 insertions, 9 deletions

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)