From 4d834bdc12acef0f7353da8a22ef0480f818bdb8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 20 Nov 2023 13:17:42 +0100 Subject: [PATCH] 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 ++ .../language/cps/guile-vm/lower-primcalls.scm | 30 ++++++------------- .../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 ($ _ (? uint? y))) (rsh/immediate y (x))) + (('logand x ($ _ (? exact-integer? y))) + (logand/immediate y (x))) + (('logand ($ _ (? 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},