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

Specialize u64 comparisons

Browse source 
* module/language/cps/specialize-numbers.scm
  (specialize-u64-comparison): New function.
* module/language/cps/specialize-numbers.scm (specialize-operations):
  Rename from specialize-f64-operations, as it will specialize both
  kinds.  Add a case to specialize u64 comparisons.
* module/language/cps/specialize-numbers.scm (specialize-numbers): Adapt
  to specialize-operations name change.
This commit is contained in:
Andy Wingo 2015-11-20 09:26:56 +01:00
parent 07607f66b8
commit 163fcf5adb
1 changed files with 33 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -81,7 +81,22 @@
($continue kunbox-b src
($primcall 'scm->f64 (a)))))))
(define (specialize-f64-operations cps)
(define (specialize-u64-comparison cps kf kt src op a b)
(pk 'specialize cps kf kt src op a b)
(let ((op (symbol-append 'u64- op)))
(with-cps cps
(letv u64-a u64-b)
(letk kop ($kargs ('u64-b) (u64-b)
($continue kf src
($branch kt ($primcall op (u64-a u64-b))))))
(letk kunbox-b ($kargs ('u64-a) (u64-a)
($continue kop src
($primcall 'scm->u64 (b)))))
(build-term
($continue kunbox-b src
($primcall 'scm->u64 (a)))))))
(define (specialize-operations cps)
(define (visit-cont label cont cps types)
(match cont
(($ $kfun)
@ -101,6 +116,22 @@
(setk label ($kargs names vars ,body)))
cps)
types))))))
(($ $kargs names vars
($ $continue k src
($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a b)))))
(call-with-values (lambda () (lookup-pre-type types label a))
(lambda (a-type a-min a-max)
(call-with-values (lambda () (lookup-pre-type types label b))
(lambda (b-type b-min b-max)
(values
(if (and (eqv? a-type b-type &exact-integer)
(<= 0 a-min a-max #xffffffffffffffff)
(<= 0 b-min b-max #xffffffffffffffff))
(with-cps cps
(let$ body (specialize-u64-comparison k kt src op a b))
(setk label ($kargs names vars ,body)))
cps)
types))))))
(_ (values cps types))))
(values (intmap-fold visit-cont cps cps #f)))
@ -342,4 +373,4 @@
;; Type inference wants a renumbered graph; OK.
(let ((cps (renumber cps)))
(with-fresh-name-state cps
(specialize-f64-phis (specialize-f64-operations cps)))))
(specialize-f64-phis (specialize-operations cps)))))