mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 09:10:22 +02:00
Code Activity

Add untagged bitwise operations

Browse source 
* libguile/vm-engine.c (ulogand, ulogior, ulogsub, ulsh, ursh)
  (scm->u64/truncate): New ops.
* module/language/cps/compile-bytecode.scm (compile-function):
* module/language/cps/effects-analysis.scm:
* module/language/cps/slot-allocation.scm (compute-var-representations):
* module/language/cps/specialize-primcalls.scm (specialize-primcalls):
* module/language/cps/types.scm:
* module/language/cps/utils.scm (compute-constant-values):
* module/system/vm/assembler.scm: Wire up support for the new ops.
This commit is contained in:
Andy Wingo 2015-12-01 10:51:00 +01:00
parent eb86afcc7a
commit 3d6dd2f81c
8 changed files with 170 additions and 9 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -204,6 +204,8 @@
(emit-f64->scm asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'scm->u64 (src))
(emit-scm->u64 asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'scm->u64/truncate (src))
(emit-scm->u64/truncate asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'load-u64 (src))
(emit-load-u64 asm (from-sp dst) (constant src)))
(($ $primcall 'u64->scm (src))

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

@ -367,6 +367,7 @@ is or might be a read or a write to the same location as A."
((load-f64 _))
((f64->scm _))
((scm->u64 _) &type-check)
((scm->u64/truncate _) &type-check)
((load-u64 _))
((u64->scm _))
((scm->s64 _) &type-check)
@ -467,6 +468,11 @@ is or might be a read or a write to the same location as A."
((logxor . _) &type-check)
((logsub . _) &type-check)
((lognot . _) &type-check)
((ulogand . _))
((ulogior . _))
((ulogsub . _))
((ursh . _))
((ulsh . _))
((logtest a b) &type-check)
((logbit? a b) &type-check)
((sqrt _) &type-check)

3
module/language/cps/slot-allocation.scm
View file

@ -800,9 +800,10 @@ are comparable with eqv?. A tmp slot may be used."
'bv-f32-ref 'bv-f64-ref
'fadd 'fsub 'fmul 'fdiv))
(intmap-add representations var 'f64))
(($ $primcall (or 'scm->u64 'load-u64
(($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64
'bv-length 'vector-length 'string-length
'uadd 'usub 'umul
'ulogand 'ulogior 'ulogsub 'ursh 'ulsh
'uadd/immediate 'usub/immediate 'umul/immediate
'bv-u8-ref 'bv-u16-ref 'bv-u32-ref 'bv-u64-ref))
(intmap-add representations var 'u64))

1
module/language/cps/specialize-primcalls.scm
View file

@ -66,6 +66,7 @@
(('umul (? u8? x) y) (build-exp ($primcall 'umul/immediate (y x))))
(('scm->f64 (? f64?)) (rename 'load-f64))
(('scm->u64 (? u64?)) (rename 'load-u64))
(('scm->u64/truncate (? u64?)) (rename 'load-u64))
(('scm->s64 (? s64?)) (rename 'load-s64))
(_ #f)))
(intmap-map

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

@ -733,9 +733,15 @@ minimum, and maximum."
(check-type scm &exact-integer 0 #xffffffffffffffff))
(define-type-inferrer (scm->u64 scm result)
(restrict! scm &exact-integer 0 #xffffffffffffffff)
(define! result &u64 (max (&min scm) 0) (min (&max scm) #xffffffffffffffff)))
(define! result &u64 (max (&min scm) 0) (min (&max scm) &u64-max)))
(define-type-aliases scm->u64 load-u64)
(define-type-checker (scm->u64/truncate scm)
(check-type scm &exact-integer &range-min &range-max))
(define-type-inferrer (scm->u64/truncate scm result)
(restrict! scm &exact-integer &range-min &range-max)
(define! result &u64 0 &u64-max))
(define-type-checker (u64->scm u64)
#t)
(define-type-inferrer (u64->scm u64 result)
@ -1190,6 +1196,25 @@ minimum, and maximum."
(min -- -+ ++ +-)
(max -- -+ ++ +-))))
(define-simple-type-checker (ursh &u64 &u64))
(define-type-inferrer (ursh a b result)
(restrict! a &u64 0 &u64-max)
(restrict! b &u64 0 &u64-max)
(define! result &u64
(ash (&min a) (- (&max b)))
(ash (&max a) (- (&min b)))))
(define-simple-type-checker (ulsh &u64 &u64))
(define-type-inferrer (ulsh a b result)
(restrict! a &u64 0 &u64-max)
(restrict! b &u64 0 &u64-max)
(if (and (< (&max b) 64)
(<= (ash (&max a) (&max b)) &u64-max))
;; No overflow; we can be precise.
(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 (next-power-of-two n)
(let lp ((out 1))
(if (< n out)
@ -1212,6 +1237,12 @@ minimum, and maximum."
(logand-min (&min a) (&min b))
(logand-max (&max a) (&max b))))
(define-simple-type-checker (ulogand &u64 &u64))
(define-type-inferrer (ulogand a b result)
(restrict! a &u64 0 &u64-max)
(restrict! b &u64 0 &u64-max)
(define! result &u64 0 (max (&max a) (&max b))))
(define-simple-type-checker (logsub &exact-integer &exact-integer))
(define-type-inferrer (logsub a b result)
(define (logsub-bounds min-a max-a min-b max-b)
@ -1237,6 +1268,12 @@ minimum, and maximum."
(lambda (min max)
(define! result &exact-integer min max))))
(define-simple-type-checker (ulogsub &u64 &u64))
(define-type-inferrer (ulogsub a b result)
(restrict! a &u64 0 &u64-max)
(restrict! b &u64 0 &u64-max)
(define! result &u64 0 (&max a)))
(define-simple-type-checker (logior &exact-integer &exact-integer))
(define-type-inferrer (logior a b result)
;; Saturate all bits of val.
@ -1258,6 +1295,14 @@ minimum, and maximum."
(logior-min (&min a) (&min b))
(logior-max (&max a) (&max b))))
(define-simple-type-checker (ulogior &u64 &u64))
(define-type-inferrer (ulogior a b result)
(restrict! a &u64 0 &u64-max)
(restrict! b &u64 0 &u64-max)
(define! result &u64
(max (&min a) (&min b))
(1- (next-power-of-two (logior (&max a) (&max b))))))
;; For our purposes, treat logxor the same as logior.
(define-type-aliases logior logxor)

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

@ -214,7 +214,7 @@ disjoint, an error will be signalled."
(if (and f64 (number? f64) (inexact? f64) (real? f64))
(intmap-add! out var f64)
out)))
(($ $primcall 'scm->u64 (val))
(($ $primcall (or 'scm->u64 'scm->u64/truncate) (val))
(let ((u64 (intmap-ref out val (lambda (_) #f))))
(if (and u64 (number? u64) (exact-integer? u64)
(<= 0 u64 #xffffFFFFffffFFFF))