From 9514dc7b95c1e8041dd1ddc84e46a2a37b178d20 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 2 Dec 2015 21:48:10 +0100 Subject: [PATCH] Add ursh/immediate and ulsh/immediate ops * libguile/vm-engine.c (ursh/immediate, ulsh/immediate): New ops. * module/language/cps/effects-analysis.scm: * module/language/cps/slot-allocation.scm (compute-var-representations) (compute-needs-slot): * module/language/cps/specialize-primcalls.scm (specialize-primcalls): * module/language/cps/compile-bytecode.scm (compile-function): * module/system/vm/assembler.scm: * module/language/cps/types.scm: Add support for new ops, and specialize ursh and ulsh. --- libguile/vm-engine.c | 34 ++++++++++++++++++-- module/language/cps/compile-bytecode.scm | 6 ++++ module/language/cps/effects-analysis.scm | 2 ++ module/language/cps/slot-allocation.scm | 4 ++- module/language/cps/specialize-primcalls.scm | 5 +++ module/language/cps/types.scm | 2 ++ module/system/vm/assembler.scm | 2 ++ 7 files changed, 52 insertions(+), 3 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 99ff7804f..c3663150f 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3609,8 +3609,38 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (1); } - VM_DEFINE_OP (168, unused_168, NULL, NOP) - VM_DEFINE_OP (169, unused_169, NULL, NOP) + /* ursh/immediate dst:8 a:8 b:8 + * + * Shift the u64 value in A right by the immediate B bits, and place + * the result in DST. Only the lower 6 bits of B are used. + */ + VM_DEFINE_OP (168, ursh_immediate, "ursh/immediate", OP1 (X8_S8_S8_C8) | OP_DST) + { + scm_t_uint8 dst, a, b; + + UNPACK_8_8_8 (op, dst, a, b); + + SP_SET_U64 (dst, SP_REF_U64 (a) >> (b & 63)); + + NEXT (1); + } + + /* ulsh/immediate dst:8 a:8 b:8 + * + * Shift the u64 value in A left by the immediate B bits, and place + * the result in DST. Only the lower 6 bits of B are used. + */ + VM_DEFINE_OP (169, ulsh_immediate, "ulsh/immediate", OP1 (X8_S8_S8_C8) | OP_DST) + { + scm_t_uint8 dst, a, b; + + UNPACK_8_8_8 (op, dst, a, b); + + SP_SET_U64 (dst, SP_REF_U64 (a) << (b & 63)); + + NEXT (1); + } + VM_DEFINE_OP (170, unused_170, NULL, NOP) VM_DEFINE_OP (171, unused_171, NULL, NOP) VM_DEFINE_OP (172, unused_172, NULL, NOP) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index d4a534598..dc2894821 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -194,6 +194,12 @@ (($ $primcall 'umul/immediate (x y)) (emit-umul/immediate asm (from-sp dst) (from-sp (slot x)) (constant y))) + (($ $primcall 'ursh/immediate (x y)) + (emit-ursh/immediate asm (from-sp dst) (from-sp (slot x)) + (constant y))) + (($ $primcall 'ulsh/immediate (x y)) + (emit-ulsh/immediate asm (from-sp dst) (from-sp (slot x)) + (constant y))) (($ $primcall 'builtin-ref (name)) (emit-builtin-ref asm (from-sp dst) (constant name))) (($ $primcall 'scm->f64 (src)) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index fb64cac21..37fb7406d 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -473,6 +473,8 @@ is or might be a read or a write to the same location as A." ((ulogsub . _)) ((ursh . _)) ((ulsh . _)) + ((ursh/immediate . _)) + ((ulsh/immediate . _)) ((logtest a b) &type-check) ((logbit? a b) &type-check) ((sqrt _) &type-check) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index dd860bea7..6e9188aa0 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -350,7 +350,8 @@ the definitions that are live before and after LABEL, as intsets." (($ $primcall 'struct-set!/immediate (s n x)) (defs+* (intset s x))) (($ $primcall (or 'add/immediate 'sub/immediate - 'uadd/immediate 'usub/immediate 'umul/immediate) + 'uadd/immediate 'usub/immediate 'umul/immediate + 'ursh/immediate 'ulsh/immediate) (x y)) (defs+ x)) (($ $primcall 'builtin-ref (idx)) @@ -805,6 +806,7 @@ are comparable with eqv?. A tmp slot may be used." 'uadd 'usub 'umul 'ulogand 'ulogior 'ulogsub 'ursh 'ulsh 'uadd/immediate 'usub/immediate 'umul/immediate + 'ursh/immediate 'ulsh/immediate 'bv-u8-ref 'bv-u16-ref 'bv-u32-ref 'bv-u64-ref)) (intmap-add representations var 'u64)) (($ $primcall (or 'scm->s64 'load-s64 diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm index 710cc32a1..a52e34456 100644 --- a/module/language/cps/specialize-primcalls.scm +++ b/module/language/cps/specialize-primcalls.scm @@ -33,6 +33,9 @@ (define (specialize-primcalls conts) (let ((constants (compute-constant-values conts))) + (define (u6? var) + (let ((val (intmap-ref constants var (lambda (_) #f)))) + (and (exact-integer? val) (<= 0 val 63)))) (define (u8? var) (let ((val (intmap-ref constants var (lambda (_) #f)))) (and (exact-integer? val) (<= 0 val 255)))) @@ -64,6 +67,8 @@ (('usub x (? u8? y)) (build-exp ($primcall 'usub/immediate (x y)))) (('umul x (? u8? y)) (build-exp ($primcall 'umul/immediate (x y)))) (('umul (? u8? x) y) (build-exp ($primcall 'umul/immediate (y x)))) + (('ursh x (? u6? y)) (build-exp ($primcall 'ursh/immediate (x y)))) + (('ulsh x (? u6? y)) (build-exp ($primcall 'ulsh/immediate (x y)))) (('scm->f64 (? f64?)) (rename 'load-f64)) (('scm->u64 (? u64?)) (rename 'load-u64)) (('scm->u64/truncate (? u64?)) (rename 'load-u64)) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 6b035dc41..a85617062 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -1203,6 +1203,7 @@ minimum, and maximum." (define! result &u64 (ash (&min a) (- (&max b))) (ash (&max a) (- (&min b))))) +(define-type-aliases ursh ursh/immediate) (define-simple-type-checker (ulsh &u64 &u64)) (define-type-inferrer (ulsh a b result) @@ -1214,6 +1215,7 @@ minimum, and maximum." (define! result &u64 (ash (&min a) (&min b)) (ash (&max a) (&max b))) ;; Otherwise assume the whole range. (define! result &u64 0 &u64-max))) +(define-type-aliases ulsh ulsh/immediate) (define (next-power-of-two n) (let lp ((out 1)) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index ff7e53cb4..012d6eed2 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -158,6 +158,8 @@ (emit-ulogsub* . emit-ulogsub) (emit-ursh* . emit-ursh) (emit-ulsh* . emit-ulsh) + (emit-ursh/immediate* . emit-ursh/immediate) + (emit-ulsh/immediate* . emit-ulsh/immediate) (emit-make-vector* . emit-make-vector) (emit-make-vector/immediate* . emit-make-vector/immediate) (emit-vector-length* . emit-vector-length)