summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2023-11-20 13:17:42 +0100
committerAndy Wingo <wingo@pobox.com>2023-11-20 13:43:47 +0100
commit4d834bdc12acef0f7353da8a22ef0480f818bdb8 (patch)
treeb14e8f877ec7be76124ef12f79eb75646558394f /module/language
parent5b0c261b04e02e467db672c7abb328a4a16a1caa (diff)
downloadguile-4d834bdc12acef0f7353da8a22ef0480f818bdb8.tar.gz
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.
Diffstat (limited to 'module/language')
-rw-r--r--module/language/cps/compile-bytecode.scm2
-rw-r--r--module/language/cps/effects-analysis.scm2
-rw-r--r--module/language/cps/guile-vm/lower-primcalls.scm30
-rw-r--r--module/language/cps/guile-vm/reify-primitives.scm25
-rw-r--r--module/language/cps/specialize-numbers.scm14
-rw-r--r--module/language/cps/types.scm14
-rw-r--r--module/language/cps/utils.scm1
-rw-r--r--module/language/tree-il/compile-cps.scm4
8 files changed, 62 insertions, 30 deletions
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)
@@ -369,14 +385,6 @@
(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))))
(with-cps cps
@@ -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