diff options
-rw-r--r-- | libguile/intrinsics.c | 21 | ||||
-rw-r--r-- | libguile/intrinsics.h | 5 | ||||
-rw-r--r-- | libguile/jit.c | 30 | ||||
-rw-r--r-- | libguile/vm-engine.c | 44 | ||||
-rw-r--r-- | module/language/cps/compile-bytecode.scm | 6 | ||||
-rw-r--r-- | module/language/cps/effects-analysis.scm | 4 | ||||
-rw-r--r-- | module/language/cps/reify-primitives.scm | 25 | ||||
-rw-r--r-- | module/language/tree-il/compile-bytecode.scm | 19 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 11 |
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) |