mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-30 08:50:23 +02:00
Code Activity

Specialize comparisons to SCM as s64

Browse source 
* module/language/cps/specialize-numbers.scm (specialize-s64-comparison)
  (specialize-s64-scm-comparison, specialize-scm-s64-comparison): New
  helpers.
  (specialize-scm-u64-comparison, specialize-u64-scm-comparison):
  Remove.  Comparing SCM as s64 is better as fixnums are a subset of
  s64, not u64.
  (specialize-operations): Prefer s64 comparisons when we can't
  specialize both arguments; this at least inlines the fixnum case.
This commit is contained in:
Andy Wingo 2017-11-09 13:16:14 +01:00
parent 7a7f71de5c
commit 9da03136e5
1 changed files with 57 additions and 46 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -189,71 +189,75 @@
($continue kunbox-b src ($continue kunbox-b src
($primcall 'scm->u64 #f (a))))))) ($primcall 'scm->u64 #f (a)))))))
(define (specialize-u64-scm-comparison cps kf kt src op a-u64 b-scm) (define (specialize-s64-comparison cps kf kt src op a b)
(let ((u64-op (symbol-append 'u64- op))) (let ((op (symbol-append 's64- op)))
(with-cps cps (with-cps cps
(letv u64 s64 z64 sunk) (letv s64-a s64-b)
(letk kop ($kargs ('s64-b) (s64-b)
($continue kf src
($branch kt ($primcall op #f (s64-a s64-b))))))
(letk kunbox-b ($kargs ('s64-a) (s64-a)
($continue kop src
($primcall 'scm->s64 #f (b)))))
(build-term
($continue kunbox-b src
($primcall 'scm->s64 #f (a)))))))
(define (specialize-s64-scm-comparison cps kf kt src op a-s64 b-scm)
(let ((s64-op (match op ('= 's64-=) ('< 's64-<))))
(with-cps cps
(letv a b sunk)
(letk kheap ($kargs ('sunk) (sunk) (letk kheap ($kargs ('sunk) (sunk)
($continue kf src ($continue kf src
($branch kt ($primcall op #f (sunk b-scm)))))) ($branch kt ($primcall op #f (sunk b-scm))))))
;; Re-box the variable. FIXME: currently we use a specially ;; Re-box the variable. FIXME: currently we use a specially
;; marked u64->scm to avoid CSE from hoisting the allocation ;; marked s64->scm to avoid CSE from hoisting the allocation
;; again. Instaed we should just use a-u64 directly and implement ;; again. Instaed we should just use a-s64 directly and implement
;; an allocation sinking pass that should handle this.. ;; an allocation sinking pass that should handle this..
(letk kretag ($kargs () () (letk kretag ($kargs () ()
($continue kheap src ($continue kheap src
($primcall 'u64->scm/unlikely #f (u64))))) ($primcall 's64->scm/unlikely #f (a)))))
(letk kcmp ($kargs () () (letk kb ($kargs ('b) (b)
($continue kf src ($continue kf src
($branch kt ($primcall u64-op #f (u64 s64)))))) ($branch kt ($primcall s64-op #f (a b))))))
(letk kz64 ($kargs ('z64) (z64)
($continue kcmp src
($branch kf ($primcall 's64-< #f (s64 z64))))))
(letk ks64 ($kargs ('s64) (s64)
($continue kz64 src ($primcall 'load-s64 0 ()))))
(letk kfix ($kargs () () (letk kfix ($kargs () ()
($continue ks64 src ($continue kb src
($primcall 'untag-fixnum #f (b-scm))))) ($primcall 'untag-fixnum #f (b-scm)))))
(letk ku64 ($kargs ('u64) (u64) (letk ka ($kargs ('a) (a)
($continue kretag src ($continue kretag src
($branch kfix ($primcall 'fixnum? #f (b-scm)))))) ($branch kfix ($primcall 'fixnum? #f (b-scm))))))
(build-term (build-term
($continue ku64 src ($continue ka src
($primcall 'scm->u64 #f (a-u64))))))) ($primcall 'scm->s64 #f (a-s64)))))))
(define (specialize-scm-u64-comparison cps kf kt src op a-scm b-u64) (define (specialize-scm-s64-comparison cps kf kt src op a-scm b-s64)
(match op (match op
('= (specialize-u64-scm-comparison cps kf kt src op b-u64 a-scm)) ('= (specialize-s64-scm-comparison cps kf kt src op b-s64 a-scm))
('< ('<
(with-cps cps (with-cps cps
(letv u64 s64 z64 sunk) (letv a b sunk)
(letk kheap ($kargs ('sunk) (sunk) (letk kheap ($kargs ('sunk) (sunk)
($continue kf src ($continue kf src
($branch kt ($primcall '< #f (a-scm sunk)))))) ($branch kt ($primcall '< #f (a-scm sunk))))))
;; Re-box the variable. FIXME: currently we use a specially ;; Re-box the variable. FIXME: currently we use a specially
;; marked u64->scm to avoid CSE from hoisting the allocation ;; marked s64->scm to avoid CSE from hoisting the allocation
;; again. Instaed we should just use a-u64 directly and implement ;; again. Instaed we should just use a-s64 directly and implement
;; an allocation sinking pass that should handle this.. ;; an allocation sinking pass that should handle this..
(letk kretag ($kargs () () (letk kretag ($kargs () ()
($continue kheap src ($continue kheap src
($primcall 'u64->scm/unlikely #f (u64))))) ($primcall 's64->scm/unlikely #f (b)))))
(letk kcmp ($kargs () () (letk ka ($kargs ('a) (a)
($continue kf src ($continue kf src
($branch kt ($primcall 'u64-< #f (s64 u64)))))) ($branch kt ($primcall 's64-< #f (a b))))))
(letk kz64 ($kargs ('z64) (z64)
($continue kcmp src
($branch kt ($primcall 's64-< #f (s64 z64))))))
(letk ks64 ($kargs ('s64) (s64)
($continue kz64 src ($primcall 'load-s64 0 ()))))
(letk kfix ($kargs () () (letk kfix ($kargs () ()
($continue ks64 src ($continue ka src
($primcall 'untag-fixnum #f (a-scm))))) ($primcall 'untag-fixnum #f (a-scm)))))
(letk ku64 ($kargs ('u64) (u64) (letk kb ($kargs ('b) (b)
($continue kretag src ($continue kretag src
($branch kfix ($primcall 'fixnum? #f (a-scm)))))) ($branch kfix ($primcall 'fixnum? #f (a-scm))))))
(build-term (build-term
($continue ku64 src ($continue kb src
($primcall 'scm->u64 #f (b-u64)))))))) ($primcall 'scm->s64 #f (b-s64))))))))
(define (specialize-f64-comparison cps kf kt src op a b) (define (specialize-f64-comparison cps kf kt src op a b)
(let ((op (symbol-append 'f64- op))) (let ((op (symbol-append 'f64- op)))
@ -395,6 +399,9 @@ BITS indicating the significant bits needed for a variable. BITS may be
(and (type<=? type &type) (<= &min min max &max))))) (and (type<=? type &type) (<= &min min max &max)))))
(define (u64-operand? var) (define (u64-operand? var)
(operand-in-range? var &exact-integer 0 #xffffffffffffffff)) (operand-in-range? var &exact-integer 0 #xffffffffffffffff))
(define (s64-operand? var)
(operand-in-range? var &exact-integer
(- #x8000000000000000) #x7fffffffffffffff))
(define (all-u64-bits-set? var) (define (all-u64-bits-set? var)
(operand-in-range? var &exact-integer (operand-in-range? var &exact-integer
#xffffffffffffffff #xffffffffffffffff
@ -566,16 +573,20 @@ BITS indicating the significant bits needed for a variable. BITS may be
(with-cps cps (with-cps cps
(let$ body (specialize-f64-comparison k kt src op a b)) (let$ body (specialize-f64-comparison k kt src op a b))
(setk label ($kargs names vars ,body)))) (setk label ($kargs names vars ,body))))
((u64-operand? a) ((and (u64-operand? a) (u64-operand? b))
(let ((specialize (if (u64-operand? b) (with-cps cps
specialize-u64-comparison (let$ body (specialize-u64-comparison k kt src op a b))
specialize-u64-scm-comparison))) (setk label ($kargs names vars ,body))))
((s64-operand? a)
(let ((specialize (if (s64-operand? b)
specialize-s64-comparison
specialize-s64-scm-comparison)))
(with-cps cps (with-cps cps
(let$ body (specialize k kt src op a b)) (let$ body (specialize k kt src op a b))
(setk label ($kargs names vars ,body))))) (setk label ($kargs names vars ,body)))))
((u64-operand? b) ((s64-operand? b)
(with-cps cps (with-cps cps
(let$ body (specialize-scm-u64-comparison k kt src op a b)) (let$ body (specialize-scm-s64-comparison k kt src op a b))
(setk label ($kargs names vars ,body)))) (setk label ($kargs names vars ,body))))
(else cps)) (else cps))
types types