diff options
author | Andy Wingo <wingo@pobox.com> | 2023-11-20 13:17:42 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2023-11-20 13:43:47 +0100 |
commit | 4d834bdc12acef0f7353da8a22ef0480f818bdb8 (patch) | |
tree | b14e8f877ec7be76124ef12f79eb75646558394f /module/language | |
parent | 5b0c261b04e02e467db672c7abb328a4a16a1caa (diff) | |
download | guile-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.scm | 2 | ||||
-rw-r--r-- | module/language/cps/effects-analysis.scm | 2 | ||||
-rw-r--r-- | module/language/cps/guile-vm/lower-primcalls.scm | 30 | ||||
-rw-r--r-- | module/language/cps/guile-vm/reify-primitives.scm | 25 | ||||
-rw-r--r-- | module/language/cps/specialize-numbers.scm | 14 | ||||
-rw-r--r-- | module/language/cps/types.scm | 14 | ||||
-rw-r--r-- | module/language/cps/utils.scm | 1 | ||||
-rw-r--r-- | module/language/tree-il/compile-cps.scm | 4 |
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 |