[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/02: Simplify module variable lookup slow-path
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 02/02: Simplify module variable lookup slow-path |
|
Date: |
Mon, 26 Apr 2021 03:50:10 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 83023160b18ec92ba4a80bd2a27b4d45e3878699
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Mon Apr 26 09:36:56 2021 +0200
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.
---
libguile/intrinsics.c | 21 ++++++++++++-
libguile/intrinsics.h | 5 +++-
libguile/jit.c | 30 +++++++++++++++++++
libguile/vm-engine.c | 44 ++++++++++++++++++++++++++--
module/language/cps/compile-bytecode.scm | 6 ++++
module/language/cps/effects-analysis.scm | 4 ++-
module/language/cps/reify-primitives.scm | 25 +++++++++++++++-
module/language/tree-il/compile-bytecode.scm | 19 +++++++-----
module/system/vm/assembler.scm | 11 +++++++
9 files changed, 152 insertions(+), 13 deletions(-)
diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c
index 92b587c..10f897a 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 d8b927c..936e06d 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 45208be..8420829 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 bf64684..510563c 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 7f4f977..a2c951d 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 7315fce..365c280 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 710ad6f..d0441ff 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 419f5c8..c495d2a 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 c94cec3..8a6ca4e 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)