mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Add logand/immediate, ulogand/immediate primcalls

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2023-11-20 13:17:42 +01:00
parent 5b0c261b04
commit 4d834bdc12
12 changed files with 101 additions and 34 deletions
Download patch file Download diff file Expand all files Collapse all files

19
libguile/jit.c
View file

@ -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)
{

4
libguile/loader.h
View file

@ -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 \

17
libguile/vm-engine.c
View file

@ -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)

2
module/language/cps/compile-bytecode.scm
View file

@ -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))

2
module/language/cps/effects-analysis.scm
View file

@ -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 . _))

30
module/language/cps/guile-vm/lower-primcalls.scm
View file

@ -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

25
module/language/cps/guile-vm/reify-primitives.scm
View file

@ -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

14
module/language/cps/specialize-numbers.scm
View file

@ -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

14
module/language/cps/types.scm
View file

@ -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),

1
module/language/cps/utils.scm
View file

@ -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

4
module/language/tree-il/compile-cps.scm
View file

@ -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

3
module/system/vm/assembler.scm
View file

@ -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},