wingo pushed a commit to branch main
in repository guile.
commit 4d834bdc12acef0f7353da8a22ef0480f818bdb8
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Mon Nov 20 13:17:42 2023 +0100
Add logand/immediate, ulogand/immediate primcalls
* libguile/jit.c (compile_ulogand_immediate, compile_ulogand_immediate_slow)
* libguile/vm-engine.c (ulogand_immediate): New JIT and interpreter
support for ulogand/immediate.
* module/language/cps/guile-vm/lower-primcalls.scm (string-ref):
(vtable-vtable?):
(vtable-field-boxed?): Emit ulogand/immediate.
* module/language/cps/guile-vm/reify-primitives.scm (reify-primitives):
Remove logand/immediate. Only emit ulogand/immediate if the immediate
is a u8. Refactor mul/immediate.
* module/language/cps/specialize-numbers.scm (specialize-operations):
Produce ulogand/immediate if the result is a u64.
* module/language/cps/effects-analysis.scm:
* module/language/cps/types.scm (logand/immediate): Add effect and type
inference for logand/immediate, ulogand/immediate,
* module/language/cps/utils.scm (primcall-raw-representations):
ulogand/immediate makes a u64.
* module/language/tree-il/compile-cps.scm (convert): Generate
logand/immediate if possible.
* module/language/cps/compile-bytecode.scm (compile-function):
* module/system/vm/assembler.scm (system): Add ulogand/immediate
emitter.
* libguile/loader.h (SCM_OBJCODE_MINOR_VERSION): Bump.
---
libguile/jit.c | 19 ++++++++++++++
libguile/loader.h | 4 +--
libguile/vm-engine.c | 17 ++++++++++++-
module/language/cps/compile-bytecode.scm | 2 ++
module/language/cps/effects-analysis.scm | 2 ++
module/language/cps/guile-vm/lower-primcalls.scm | 30 +++++++----------------
module/language/cps/guile-vm/reify-primitives.scm | 25 +++++++++++++------
module/language/cps/specialize-numbers.scm | 14 ++++++++++-
module/language/cps/types.scm | 14 +++++++++++
module/language/cps/utils.scm | 1 +
module/language/tree-il/compile-cps.scm | 4 +++
module/system/vm/assembler.scm | 3 ++-
12 files changed, 101 insertions(+), 34 deletions(-)
diff --git a/libguile/jit.c b/libguile/jit.c
index d582893d7..6f3a650b8 100644
--- a/libguile/jit.c
+++ b/libguile/jit.c
@@ -3529,6 +3529,25 @@ compile_ulogand_slow (scm_jit_state *j, uint32_t dst,
uint32_t a, uint32_t b)
{
}
+static void
+compile_ulogand_immediate (scm_jit_state *j, uint32_t dst, uint32_t a,
uint32_t b)
+{
+#if SIZEOF_UINTPTR_T >= 8
+ emit_sp_ref_u64 (j, T0, a);
+ emit_andi (j, T0, T0, b);
+ emit_sp_set_u64 (j, dst, T0);
+#else
+ emit_sp_ref_u64 (j, T0, T1, a);
+ emit_andi (j, T0, T0, b);
+ emit_andi (j, T1, T1, 0);
+ emit_sp_set_u64 (j, dst, T0, T1);
+#endif
+}
+static void
+compile_ulogand_immediate_slow (scm_jit_state *j, uint32_t dst, uint32_t a,
uint32_t b)
+{
+}
+
static void
compile_ulogior (scm_jit_state *j, uint32_t dst, uint32_t a, uint32_t b)
{
diff --git a/libguile/loader.h b/libguile/loader.h
index 28452a1c7..42c98fcca 100644
--- a/libguile/loader.h
+++ b/libguile/loader.h
@@ -1,4 +1,4 @@
-/* Copyright 2001,2009-2015,2018,2020,2021
+/* Copyright 2001,2009-2015,2018,2020,2021,2023
Free Software Foundation, Inc.
This file is part of Guile.
@@ -40,7 +40,7 @@
/* Major and minor versions must be single characters. */
#define SCM_OBJCODE_MAJOR_VERSION 4
#define SCM_OBJCODE_MINIMUM_MINOR_VERSION 2
-#define SCM_OBJCODE_MINOR_VERSION 6
+#define SCM_OBJCODE_MINOR_VERSION 7
#define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
#define SCM_OBJCODE_MINOR_VERSION_STRING \
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 7f41f3932..e2ea81190 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -3489,7 +3489,22 @@ VM_NAME (scm_thread *thread)
abort (); /* never reached */
}
- VM_DEFINE_OP (168, unused_168, NULL, NOP)
+ /* ulogand/immediate dst:8 src:8 imm:8
+ *
+ * Place the bitwise AND of the u64 value SRC with the immediate IMM
+ * into DST.
+ */
+ VM_DEFINE_OP (168, ulogand_immediate, "ulogand/immediate", DOP1
(X8_S8_S8_C8))
+ {
+ uint8_t dst, src, imm;
+ uint64_t x;
+
+ UNPACK_8_8_8 (op, dst, src, imm);
+ x = SP_REF_U64 (src);
+ SP_SET_U64 (dst, x & (uint64_t) imm);
+ NEXT (1);
+ }
+
VM_DEFINE_OP (169, unused_169, NULL, NOP)
VM_DEFINE_OP (170, unused_170, NULL, NOP)
VM_DEFINE_OP (171, unused_171, NULL, NOP)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index ad5e0024d..1756274c6 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -252,6 +252,8 @@
(emit-srsh/immediate asm (from-sp dst) (from-sp (slot x)) y))
(($ $primcall 'ulsh/immediate y (x))
(emit-ulsh/immediate asm (from-sp dst) (from-sp (slot x)) y))
+ (($ $primcall 'ulogand/immediate y (x))
+ (emit-ulogand/immediate asm (from-sp dst) (from-sp (slot x)) y))
(($ $primcall 'builtin-ref idx ())
(emit-builtin-ref asm (from-sp dst) idx))
(($ $primcall 'scm->f64 #f (src))
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 845394de0..50c7007e4 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -694,11 +694,13 @@ the LABELS that are clobbered by the effects of LABEL."
((rsh/immediate n) &type-check)
((lsh/immediate n) &type-check)
((logand . _) &type-check)
+ ((logand/immediate . _) &type-check)
((logior . _) &type-check)
((logxor . _) &type-check)
((logsub . _) &type-check)
((lognot . _) &type-check)
((ulogand . _))
+ ((ulogand/immediate . _))
((ulogior . _))
((ulogxor . _))
((ulogsub . _))
diff --git a/module/language/cps/guile-vm/lower-primcalls.scm
b/module/language/cps/guile-vm/lower-primcalls.scm
index 481721062..87b258f94 100644
--- a/module/language/cps/guile-vm/lower-primcalls.scm
+++ b/module/language/cps/guile-vm/lower-primcalls.scm
@@ -279,19 +279,15 @@
(define vtable-validated-mask #b11)
(define vtable-validated-value #b11)
(with-cps cps
- (letv flags mask res)
+ (letv flags res)
(letk ktest
($kargs ('res) (res)
($branch kf kt src
'u64-imm-= vtable-validated-value (res))))
- (letk kand
- ($kargs ('mask) (mask)
- ($continue ktest src
- ($primcall 'ulogand #f (flags mask)))))
(letk kflags
($kargs ('flags) (flags)
- ($continue kand src
- ($primcall 'load-u64 vtable-validated-mask ()))))
+ ($continue ktest src
+ ($primcall 'ulogand/immediate vtable-validated-mask (flags)))))
(build-term
($continue kflags src
($primcall 'word-ref/immediate
@@ -351,18 +347,14 @@
(define vtable-index-unboxed-fields 6) ; FIXME: pull from struct.h
(define vtable-offset-unboxed-fields (1+ vtable-index-unboxed-fields))
(with-cps cps
- (letv ptr word bits mask res)
+ (letv ptr word bits res)
(letk ktest
($kargs ('res) (res)
($branch kf kt src 'u64-imm-= 0 (res))))
- (letk kand
- ($kargs ('mask) (mask)
- ($continue ktest src
- ($primcall 'ulogand #f (mask bits)))))
(letk kbits
($kargs ('bits) (bits)
- ($continue kand src
- ($primcall 'load-u64 (ash 1 (logand idx 31)) ()))))
+ ($continue ktest src
+ ($primcall 'ulogand/immediate (ash 1 (logand idx 31)) (bits)))))
(letk kword
($kargs ('word) (word)
($continue kbits src
@@ -428,7 +420,7 @@
(define-primcall-lowerer (string-ref cps k src #f (s uidx))
(define stringbuf-f-wide #x400)
(with-cps cps
- (letv start upos buf ptr tag mask bits uwpos u32)
+ (letv start upos buf ptr tag bits uwpos u32)
(letk kassume
($kargs ('u32) (u32)
($continue k src
@@ -448,14 +440,10 @@
(letk kcmp
($kargs ('bits) (bits)
($branch kwide knarrow src 'u64-imm-= 0 (bits))))
- (letk kmask
- ($kargs ('mask) (mask)
- ($continue kcmp src
- ($primcall 'ulogand #f (tag mask)))))
(letk ktag
($kargs ('tag) (tag)
- ($continue kmask src
- ($primcall 'load-u64 stringbuf-f-wide ()))))
+ ($continue kcmp src
+ ($primcall 'ulogand/immediate stringbuf-f-wide (tag)))))
(letk kptr
($kargs ('ptr) (ptr)
($continue ktag src
diff --git a/module/language/cps/guile-vm/reify-primitives.scm
b/module/language/cps/guile-vm/reify-primitives.scm
index 035a3266b..b8c2c778a 100644
--- a/module/language/cps/guile-vm/reify-primitives.scm
+++ b/module/language/cps/guile-vm/reify-primitives.scm
@@ -255,6 +255,22 @@
($continue ktest src
($primcall 'cache-ref cache-key ()))))))))
+(define-ephemeral (mul/immediate cps k src param a)
+ (with-cps cps
+ (letv imm)
+ (letk kop ($kargs ('imm) (imm)
+ ($continue k src ($primcall 'mul #f (a imm)))))
+ (build-term
+ ($continue kop src ($const param)))))
+
+(define-ephemeral (logand/immediate cps k src param a)
+ (with-cps cps
+ (letv imm)
+ (letk kop ($kargs ('imm) (imm)
+ ($continue k src ($primcall 'logand #f (a imm)))))
+ (build-term
+ ($continue kop src ($const param)))))
+
;; FIXME: Instead of having to check this, instead every primcall that's
;; not ephemeral should be handled by compile-bytecode.
(define (compute-known-primitives)
@@ -368,14 +384,6 @@
($ $continue k src ($ $primcall 'load-const/unlikely val ())))
(with-cps cps
(setk label ($kargs names vars ($continue k src ($const val))))))
- (($ $kargs names vars
- ($ $continue k src ($ $primcall 'mul/immediate b (a))))
- (with-cps cps
- (letv b*)
- (letk kb ($kargs ('b) (b*)
- ($continue k src ($primcall 'mul #f (a b*)))))
- (setk label ($kargs names vars
- ($continue kb src ($const b))))))
(($ $kargs names vars
($ $continue k src
($ $primcall (or 'assume-u64 'assume-s64) (lo . hi) (val))))
@@ -433,6 +441,7 @@
;; ((ursh/immediate (u6? y) x) (ursh x y))
;; ((srsh/immediate (u6? y) x) (srsh x y))
;; ((ulsh/immediate (u6? y) x) (ulsh x y))
+ ((ulogand/immediate (u8? y) x) (ulogand x y))
(_
(match (cons name args)
(((or 'allocate-words/immediate
diff --git a/module/language/cps/specialize-numbers.scm
b/module/language/cps/specialize-numbers.scm
index 72d893b80..c7bb334bc 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2015-2021, 2023 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
@@ -116,6 +116,7 @@
(build-term
($continue ks64 src ($primcall 'u64->s64 #f (u64))))))
(define-simple-primcall scm->u64)
+(define-simple-primcall scm->u64/truncate)
(define-simple-primcall u64->scm)
(define-simple-primcall u64->scm/unlikely)
@@ -459,6 +460,11 @@ BITS indicating the significant bits needed for a
variable. BITS may be
(<= (target-most-negative-fixnum) min max (target-most-positive-fixnum)))
(define (unbox-u64 arg)
(if (fixnum-operand? arg) fixnum->u64 scm->u64))
+ (define (unbox-u64/truncate arg)
+ (cond
+ ((fixnum-operand? arg) fixnum->u64)
+ ((u64-operand? arg) scm->u64)
+ (else scm->u64/truncate)))
(define (unbox-s64 arg)
(if (fixnum-operand? arg) untag-fixnum scm->s64))
(define (rebox-s64 arg)
@@ -550,6 +556,12 @@ BITS indicating the significant bits needed for a
variable. BITS may be
(specialize-unop cps k src op param a
(unbox-u64 a) (box-u64 result))))
+ (('logand/immediate (? u64-result? ) param a)
+ (specialize-unop cps k src 'ulogand/immediate
+ (logand param (1- (ash 1 64)))
+ a
+ (unbox-u64/truncate a) (box-u64 result)))
+
(((or 'add/immediate 'sub/immediate 'mul/immediate)
(? s64-result?) (? s64-parameter?) (? s64-operand? a))
(let ((op (match op
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 597654ab8..abfca4794 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1644,10 +1644,24 @@ where (A0 <= A <= A1) and (B0 <= B <= B1)."
(lambda (min max)
(define-exact-integer! result min max))))
+(define-simple-type-checker (logand/immediate &exact-integer))
+(define-type-inferrer/param (logand/immediate param a result)
+ (restrict! a &exact-integer -inf.0 +inf.0)
+ (call-with-values (lambda ()
+ (logand-bounds (&min a) (&max a) param param))
+ (lambda (min max)
+ (define-exact-integer! result min max))))
+
(define-type-inferrer (ulogand a b result)
(restrict! a &u64 0 &u64-max)
(restrict! b &u64 0 &u64-max)
(define! result &u64 0 (min (&max/u64 a) (&max/u64 b))))
+(define-type-inferrer/param (ulogand/immediate param a result)
+ (restrict! a &u64 0 &u64-max)
+ (call-with-values (lambda ()
+ (logand-bounds (&min a) (&max a) param param))
+ (lambda (min max)
+ (define! result &u64 min max))))
(define (logsub-bounds a0 a1 b0 b1)
"Return two values: lower and upper bounds for (logsub A B),
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index ec8c2b3af..24ede7ff5 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -395,6 +395,7 @@ by a label, respectively."
ulogand ulogior ulogxor ulogsub ursh ulsh
uadd/immediate usub/immediate umul/immediate
ursh/immediate ulsh/immediate
+ ulogand/immediate
u8-ref u16-ref u32-ref u64-ref
word-ref word-ref/immediate
untag-char
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 052c9ec6f..8d0b25855 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1976,6 +1976,10 @@ use as the proc slot."
(lsh/immediate y (x)))
(('rsh x ($ <const> _ (? uint? y)))
(rsh/immediate y (x)))
+ (('logand x ($ <const> _ (? exact-integer? y)))
+ (logand/immediate y (x)))
+ (('logand ($ <const> _ (? exact-integer? x)) y)
+ (logand/immediate x (y)))
(_
(default))))
;; Tree-IL primcalls are sloppy, in that it could be that
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 0ffc0c6e3..4114c221a 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -319,6 +319,7 @@
emit-usub/immediate
emit-umul/immediate
emit-ulogand
+ emit-ulogand/immediate
emit-ulogior
emit-ulogxor
emit-ulogsub
@@ -2321,7 +2322,7 @@ needed."
;; FIXME: Define these somewhere central, shared with C.
(define *bytecode-major-version* #x0300)
-(define *bytecode-minor-version* 6)
+(define *bytecode-minor-version* 7)
(define (link-dynamic-section asm text rw rw-init frame-maps)
"Link the dynamic section for an ELF image with bytecode @var{text},
