mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-19 11:10:25 +02:00
Code Activity

Add assume-u64 and assume-s64 dataflow restrictions

Browse source 
* module/language/cps/effects-analysis.scm::
* module/language/cps/reify-primitives.scm (reify-primitives):
* module/language/cps/slot-allocation.scm (compute-var-representations):
* module/language/cps/types.scm (assume-u64, assume-s64): Add primitives
  that assume the range of a u64 or s64 value is within certain bounds.
  This is useful when extracting e.g. a length from a 64-bit word when
  you know the length is less than 2**48.
This commit is contained in:
Andy Wingo 2018-01-16 16:19:12 +01:00
parent 94fdc5cad9
commit 4829cb3ce9
4 changed files with 19 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -427,6 +427,8 @@ the LABELS that are clobbered by the effects of LABEL."
((s64->scm/unlikely _)) ((s64->scm/unlikely _))
((u64->s64 _)) ((u64->s64 _))
((s64->u64 _)) ((s64->u64 _))
((assume-u64 _))
((assume-s64 _))
((untag-fixnum _)) ((untag-fixnum _))
((tag-fixnum _)) ((tag-fixnum _))
((tag-fixnum/unlikely _))) ((tag-fixnum/unlikely _)))

6
module/language/cps/reify-primitives.scm
View file

@ -268,6 +268,12 @@
($continue k src ($primcall 'mul #f (a b*))))) ($continue k src ($primcall 'mul #f (a b*)))))
(setk label ($kargs names vars (setk label ($kargs names vars
($continue kb src ($const b)))))) ($continue kb src ($const b))))))
(($ $kargs names vars
($ $continue k src
($ $primcall (or 'assume-u64 'assume-s64) (lo . hi) (val))))
(with-cps cps
(setk label ($kargs names vars
($continue k src ($values (val)))))))
(($ $kargs names vars ($ $continue k src ($ $primcall name param args))) (($ $kargs names vars ($ $continue k src ($ $primcall name param args)))
(cond (cond
((hashq-ref *ephemeral-reifiers* name) ((hashq-ref *ephemeral-reifiers* name)

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

@ -754,6 +754,7 @@ are comparable with eqv?. A tmp slot may be used."
(($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64 (($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64
'char->integer 's64->u64 'char->integer 's64->u64
'bv-length 'string-length 'bv-length 'string-length
'assume-u64
'uadd 'usub 'umul 'uadd 'usub 'umul
'ulogand 'ulogior 'ulogxor 'ulogsub 'ursh 'ulsh 'ulogand 'ulogior 'ulogxor 'ulogsub 'ursh 'ulsh
'uadd/immediate 'usub/immediate 'umul/immediate 'uadd/immediate 'usub/immediate 'umul/immediate
@ -763,6 +764,7 @@ are comparable with eqv?. A tmp slot may be used."
'word-ref 'word-ref/immediate)) 'word-ref 'word-ref/immediate))
(intmap-add representations var 'u64)) (intmap-add representations var 'u64))
(($ $primcall (or 'untag-fixnum (($ $primcall (or 'untag-fixnum
'assume-s64
'scm->s64 'load-s64 'u64->s64 'scm->s64 'load-s64 'u64->s64
'srsh 'srsh/immediate 'srsh 'srsh/immediate
's8-ref 's16-ref 's32-ref 's64-ref 's8-ref 's16-ref 's32-ref 's64-ref

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

@ -787,6 +787,15 @@ minimum, and maximum."
(define-type-inferrer/param (pointer-ref/immediate param obj result) (define-type-inferrer/param (pointer-ref/immediate param obj result)
(define! result &other-heap-object -inf.0 +inf.0)) (define! result &other-heap-object -inf.0 +inf.0))
(define-type-inferrer/param (assume-u64 param val result)
(match param
((lo . hi)
(define! result &u64 (max lo (&min val)) (min hi (&max val))))))
(define-type-inferrer/param (assume-s64 param val result)
(match param
((lo . hi)
(define! result &s64 (max lo (&min val)) (min hi (&max val))))))