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

Better untagging of fixnums

Browse source 
* module/language/cps/compile-bytecode.scm (compile-function): Add
  support for tag-fixnum/unlikely.
* module/language/cps/cse.scm (compute-equivalent-subexpressions): Add
  equivalent subexpressions for tag-fixnum.
* module/language/cps/effects-analysis.scm:
* module/language/cps/primitives.scm (*macro-instruction-arities*): Add
  tag-fixnum/unlikely.
* module/language/cps/specialize-numbers.scm (specialize-u64-unop)
  (specialize-u64-binop, specialize-u64-shift)
  (specialize-u64-comparison): Make the arg unboxers and result boxers
  into keyword arguments.
  (specialize-s64-unop): New helper.
  (specialize-fixnum-comparison, specialize-fixnum-scm-comparison)
  (specialize-scm-fixnum-comparison): Rename from
  specialize-s64-comparison et al.  Perhaps this should be expanded
  again to include the whole s64 range, once we start to expand scm->s64
  et al.
  (specialize-operations): Specialize arithmetic, etc on signed
  operands and results.  Use less powerful unboxing/boxing ops if
  possible -- e.g. tag-fixnum instead of u64->scm.  Prefer fixnum
  comparisons over u64 comparisons.
  (compute-specializable-fixnum-vars): New helper.
  (compute-specializable-phis): Specialize fixnum phis as well.
  (specialize-primcalls): Specialize untag-fixnum of a constant to
  load-s64.
* module/language/cps/type-fold.scm (u64->scm, s64->scm):
  (scm->s64, scm->u64): Reduce to fixnum ops where possible.
* module/language/cps/types.scm: Remove type checkers for ops that don't
  throw type errors.  Alias tag-fixnum/unlikely to tag-fixnum.
This commit is contained in:
Andy Wingo 2017-11-13 14:39:30 +01:00
parent dae0004627
commit 7e79a3291e
8 changed files with 367 additions and 167 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -273,7 +273,7 @@
(from-sp (slot expected)) (from-sp (slot desired)))) (from-sp (slot expected)) (from-sp (slot desired))))
(($ $primcall 'untag-fixnum #f (src)) (($ $primcall 'untag-fixnum #f (src))
(emit-untag-fixnum asm (from-sp dst) (from-sp (slot src)))) (emit-untag-fixnum asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'tag-fixnum #f (src)) (($ $primcall (or 'tag-fixnum 'tag-fixnum/unlikely) #f (src))
(emit-tag-fixnum asm (from-sp dst) (from-sp (slot src)))) (emit-tag-fixnum asm (from-sp dst) (from-sp (slot src))))
(($ $primcall name #f args) (($ $primcall name #f args)
;; FIXME: Inline all the cases. ;; FIXME: Inline all the cases.

7
module/language/cps/cse.scm
View file

@ -334,6 +334,13 @@ false. It could be that both true and false proofs are available."
((s64) ((s64)
(add-def! `(primcall s64->scm #f ,s64) scm) (add-def! `(primcall s64->scm #f ,s64) scm)
(add-def! `(primcall tag-fixnum #f ,s64) scm)))) (add-def! `(primcall tag-fixnum #f ,s64) scm))))
(('primcall 'tag-fixnum #f fx)
(match defs
((scm)
;; NB: These definitions rely on FX having top 2 bits
;; equal to 3rd (sign) bit.
(add-def! `(primcall scm->s64 #f ,scm) fx)
(add-def! `(primcall untag-fixnum #f ,scm) fx))))
(_ #t)))) (_ #t))))
(define (visit-label label equiv-labels var-substs) (define (visit-label label equiv-labels var-substs)

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

@ -375,7 +375,8 @@ is or might be a read or a write to the same location as A."
((s64->scm _)) ((s64->scm _))
((s64->scm/unlikely _)) ((s64->scm/unlikely _))
((untag-fixnum _)) ((untag-fixnum _))
((tag-fixnum _))) ((tag-fixnum _))
((tag-fixnum/unlikely _)))
;; Bytevectors. ;; Bytevectors.
(define-primitive-effects (define-primitive-effects

1
module/language/cps/primitives.scm
View file

@ -68,6 +68,7 @@
(define *macro-instruction-arities* (define *macro-instruction-arities*
'((u64->scm/unlikely . (1 . 1)) '((u64->scm/unlikely . (1 . 1))
(s64->scm/unlikely . (1 . 1)) (s64->scm/unlikely . (1 . 1))
(tag-fixnum/unlikely . (1 . 1))
(cache-current-module! . (0 . 1)) (cache-current-module! . (0 . 1))
(cached-toplevel-box . (1 . 0)) (cached-toplevel-box . (1 . 0))
(cached-module-box . (1 . 0)))) (cached-module-box . (1 . 0))))

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

@ -52,6 +52,7 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (system base target)
#:use-module (language cps) #:use-module (language cps)
#:use-module (language cps intmap) #:use-module (language cps intmap)
#:use-module (language cps intset) #:use-module (language cps intset)
@ -82,7 +83,8 @@
($primcall 'scm->f64 #f (a))))))))) ($primcall 'scm->f64 #f (a)))))))))
(define* (specialize-u64-unop cps k src op a b #:key (define* (specialize-u64-unop cps k src op a b #:key
(unbox-a 'scm->u64)) (unbox-a 'scm->u64)
(box-result 'u64->scm))
(let ((uop (match op (let ((uop (match op
('add/immediate 'uadd/immediate) ('add/immediate 'uadd/immediate)
('sub/immediate 'usub/immediate) ('sub/immediate 'usub/immediate)
@ -93,7 +95,7 @@
(letv u64-a result) (letv u64-a result)
(letk kbox ($kargs ('result) (result) (letk kbox ($kargs ('result) (result)
($continue k src ($continue k src
($primcall 'u64->scm #f (result))))) ($primcall box-result #f (result)))))
(letk kop ($kargs ('u64-a) (u64-a) (letk kop ($kargs ('u64-a) (u64-a)
($continue kbox src ($continue kbox src
($primcall uop b (u64-a))))) ($primcall uop b (u64-a)))))
@ -101,6 +103,27 @@
($continue kop src ($continue kop src
($primcall unbox-a #f (a))))))) ($primcall unbox-a #f (a)))))))
(define* (specialize-s64-unop cps k src op a b #:key
(unbox-a 'scm->s64)
(box-result 's64->scm))
(let ((sop (match op
('add/immediate 'uadd/immediate)
('sub/immediate 'usub/immediate)
('mul/immediate 'umul/immediate)
('rsh/immediate 'srsh/immediate)
('lsh/immediate 'ulsh/immediate))))
(with-cps cps
(letv s64-a result)
(letk kbox ($kargs ('result) (result)
($continue k src
($primcall box-result #f (result)))))
(letk kop ($kargs ('s64-a) (s64-a)
($continue kbox src
($primcall sop b (s64-a)))))
(build-term
($continue kop src
($primcall unbox-a #f (a)))))))
(define (specialize-f64-binop cps k src op a b) (define (specialize-f64-binop cps k src op a b)
(let ((fop (match op (let ((fop (match op
('add 'fadd) ('add 'fadd)
@ -124,7 +147,8 @@
(define* (specialize-u64-binop cps k src op a b #:key (define* (specialize-u64-binop cps k src op a b #:key
(unbox-a 'scm->u64) (unbox-a 'scm->u64)
(unbox-b 'scm->u64)) (unbox-b 'scm->u64)
(box-result 'u64->scm))
(let ((uop (match op (let ((uop (match op
('add 'uadd) ('add 'uadd)
('sub 'usub) ('sub 'usub)
@ -137,7 +161,7 @@
(letv u64-a u64-b result) (letv u64-a u64-b result)
(letk kbox ($kargs ('result) (result) (letk kbox ($kargs ('result) (result)
($continue k src ($continue k src
($primcall 'u64->scm #f (result))))) ($primcall box-result #f (result)))))
(letk kop ($kargs ('u64-b) (u64-b) (letk kop ($kargs ('u64-b) (u64-b)
($continue kbox src ($continue kbox src
($primcall uop #f (u64-a u64-b))))) ($primcall uop #f (u64-a u64-b)))))
@ -149,7 +173,8 @@
($primcall unbox-a #f (a))))))) ($primcall unbox-a #f (a)))))))
(define* (specialize-u64-shift cps k src op a b #:key (define* (specialize-u64-shift cps k src op a b #:key
(unbox-a 'scm->u64)) (unbox-a 'scm->u64)
(box-result 'u64->scm))
(let ((uop (match op (let ((uop (match op
('rsh 'ursh) ('rsh 'ursh)
('lsh 'ulsh)))) ('lsh 'ulsh))))
@ -157,7 +182,7 @@
(letv u64-a result) (letv u64-a result)
(letk kbox ($kargs ('result) (result) (letk kbox ($kargs ('result) (result)
($continue k src ($continue k src
($primcall 'u64->scm #f (result))))) ($primcall box-result #f (result)))))
(letk kop ($kargs ('u64-a) (u64-a) (letk kop ($kargs ('u64-a) (u64-a)
($continue kbox src ($continue kbox src
($primcall uop #f (u64-a b))))) ($primcall uop #f (u64-a b)))))
@ -165,31 +190,19 @@
($continue kop src ($continue kop src
($primcall unbox-a #f (a))))))) ($primcall unbox-a #f (a)))))))
(define (truncate-u64 cps k src scm) (define* (truncate-u64 cps k src scm #:key
(unbox-a 'scm->u64/truncate)
(box-result 'u64->scm))
(with-cps cps (with-cps cps
(letv u64) (letv u64)
(letk kbox ($kargs ('u64) (u64) (letk kbox ($kargs ('u64) (u64)
($continue k src ($continue k src
($primcall 'u64->scm #f (u64))))) ($primcall box-result #f (u64)))))
(build-term (build-term
($continue kbox src ($continue kbox src
($primcall 'scm->u64/truncate #f (scm)))))) ($primcall unbox-a #f (scm))))))
(define (specialize-u64-comparison cps kf kt src op a b) (define (specialize-fixnum-comparison 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 #f (u64-a u64-b))))))
(letk kunbox-b ($kargs ('u64-a) (u64-a)
($continue kop src
($primcall 'scm->u64 #f (b)))))
(build-term
($continue kunbox-b src
($primcall 'scm->u64 #f (a)))))))
(define (specialize-s64-comparison cps kf kt src op a b)
(let ((op (symbol-append 's64- op))) (let ((op (symbol-append 's64- op)))
(with-cps cps (with-cps cps
(letv s64-a s64-b) (letv s64-a s64-b)
@ -198,12 +211,12 @@
($branch kt ($primcall op #f (s64-a s64-b)))))) ($branch kt ($primcall op #f (s64-a s64-b))))))
(letk kunbox-b ($kargs ('s64-a) (s64-a) (letk kunbox-b ($kargs ('s64-a) (s64-a)
($continue kop src ($continue kop src
($primcall 'scm->s64 #f (b))))) ($primcall 'untag-fixnum #f (b)))))
(build-term (build-term
($continue kunbox-b src ($continue kunbox-b src
($primcall 'scm->s64 #f (a))))))) ($primcall 'untag-fixnum #f (a)))))))
(define (specialize-s64-scm-comparison cps kf kt src op a-s64 b-scm) (define (specialize-fixnum-scm-comparison cps kf kt src op a-fx b-scm)
(let ((s64-op (match op ('= 's64-=) ('< 's64-<)))) (let ((s64-op (match op ('= 's64-=) ('< 's64-<))))
(with-cps cps (with-cps cps
(letv a b sunk) (letv a b sunk)
@ -212,11 +225,11 @@
($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 s64->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-s64 directly and implement ;; again. Instead we should just use a-fx 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 's64->scm/unlikely #f (a))))) ($primcall 'tag-fixnum/unlikely #f (a)))))
(letk kb ($kargs ('b) (b) (letk kb ($kargs ('b) (b)
($continue kf src ($continue kf src
($branch kt ($primcall s64-op #f (a b)))))) ($branch kt ($primcall s64-op #f (a b))))))
@ -228,11 +241,11 @@
($branch kfix ($primcall 'fixnum? #f (b-scm)))))) ($branch kfix ($primcall 'fixnum? #f (b-scm))))))
(build-term (build-term
($continue ka src ($continue ka src
($primcall 'scm->s64 #f (a-s64))))))) ($primcall 'untag-fixnum #f (a-fx)))))))
(define (specialize-scm-s64-comparison cps kf kt src op a-scm b-s64) (define (specialize-scm-fixnum-comparison cps kf kt src op a-scm b-fx)
(match op (match op
('= (specialize-s64-scm-comparison cps kf kt src op b-s64 a-scm)) ('= (specialize-fixnum-scm-comparison cps kf kt src op b-fx a-scm))
('< ('<
(with-cps cps (with-cps cps
(letv a b sunk) (letv a b sunk)
@ -241,11 +254,11 @@
($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 s64->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-s64 directly and implement ;; again. Instead 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 's64->scm/unlikely #f (b))))) ($primcall 'tag-fixnum/unlikely #f (b)))))
(letk ka ($kargs ('a) (a) (letk ka ($kargs ('a) (a)
($continue kf src ($continue kf src
($branch kt ($primcall 's64-< #f (a b)))))) ($branch kt ($primcall 's64-< #f (a b))))))
@ -257,7 +270,23 @@
($branch kfix ($primcall 'fixnum? #f (a-scm)))))) ($branch kfix ($primcall 'fixnum? #f (a-scm))))))
(build-term (build-term
($continue kb src ($continue kb src
($primcall 'scm->s64 #f (b-s64)))))))) ($primcall 'untag-fixnum #f (b-fx))))))))
(define* (specialize-u64-comparison cps kf kt src op a b #:key
(unbox-a 'scm->u64)
(unbox-b 'scm->u64))
(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 #f (u64-a u64-b))))))
(letk kunbox-b ($kargs ('u64-a) (u64-a)
($continue kop src
($primcall unbox-b #f (b)))))
(build-term
($continue kunbox-b src
($primcall unbox-a #f (a)))))))
(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)))
@ -391,6 +420,12 @@ BITS indicating the significant bits needed for a variable. BITS may be
(_ out))))))))) (_ out)))))))))
(define (specialize-operations cps) (define (specialize-operations cps)
(define (u6-parameter? param)
(<= 0 param 63))
(define (s64-parameter? param)
(<= (ash -1 63) param (1- (ash 1 63))))
(define (u64-parameter? param)
(<= 0 param (1- (ash 1 64))))
(define (visit-cont label cont cps types sigbits) (define (visit-cont label cont cps types sigbits)
(define (operand-in-range? var &type &min &max) (define (operand-in-range? var &type &min &max)
(call-with-values (lambda () (call-with-values (lambda ()
@ -398,17 +433,31 @@ BITS indicating the significant bits needed for a variable. BITS may be
(lambda (type min max) (lambda (type min max)
(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 (1- (ash 1 64))))
(define (s64-operand? var) (define (s64-operand? var)
(operand-in-range? var &exact-integer (ash -1 63) (1- (ash 1 63))))
(define (fixnum-operand? var)
(operand-in-range? var &exact-integer (operand-in-range? var &exact-integer
(- #x8000000000000000) #x7fffffffffffffff)) (target-most-negative-fixnum)
(target-most-positive-fixnum)))
(define (all-u64-bits-set? var) (define (all-u64-bits-set? var)
(operand-in-range? var &exact-integer (operand-in-range? var &exact-integer (1- (ash 1 64)) (1- (ash 1 64))))
#xffffffffffffffff (define (only-fixnum-bits-used? var)
#xffffffffffffffff)) (let ((bits (intmap-ref sigbits var)))
(and bits (= bits (logand bits (target-most-positive-fixnum))))))
(define (fixnum-result? result)
(or (only-fixnum-bits-used? result)
(call-with-values
(lambda ()
(lookup-post-type types label result 0))
(lambda (type min max)
(and (type<=? type &exact-integer)
(<= (target-most-negative-fixnum)
min max
(target-most-positive-fixnum)))))))
(define (only-u64-bits-used? var) (define (only-u64-bits-used? var)
(let ((bits (intmap-ref sigbits var))) (let ((bits (intmap-ref sigbits var)))
(and bits (= bits (logand bits #xffffFFFFffffFFFF))))) (and bits (= bits (logand bits (1- (ash 1 64)))))))
(define (u64-result? result) (define (u64-result? result)
(or (only-u64-bits-used? result) (or (only-u64-bits-used? result)
(call-with-values (call-with-values
@ -416,121 +465,188 @@ BITS indicating the significant bits needed for a variable. BITS may be
(lookup-post-type types label result 0)) (lookup-post-type types label result 0))
(lambda (type min max) (lambda (type min max)
(and (type<=? type &exact-integer) (and (type<=? type &exact-integer)
(<= 0 min max #xffffffffffffffff)))))) (<= 0 min max (1- (ash 1 64))))))))
(define (s64-result? result)
(call-with-values
(lambda ()
(lookup-post-type types label result 0))
(lambda (type min max)
(and (type<=? type &exact-integer)
(<= (ash -1 63) min max (1- (ash 1 63)))))))
(define (f64-result? result)
(call-with-values
(lambda ()
(lookup-post-type types label result 0))
(lambda (type min max)
(eqv? type &flonum))))
(define (f64-operands? vara varb) (define (f64-operands? vara varb)
(let-values (((typea mina maxa) (lookup-pre-type types label vara)) (let-values (((typea mina maxa) (lookup-pre-type types label vara))
((typeb minb maxb) (lookup-pre-type types label varb))) ((typeb minb maxb) (lookup-pre-type types label varb)))
(and (zero? (logand (logior typea typeb) (lognot &real))) (and (zero? (logand (logior typea typeb) (lognot &real)))
(or (eqv? typea &flonum) (or (eqv? typea &flonum)
(eqv? typeb &flonum))))) (eqv? typeb &flonum)))))
(define (integer-unbox-op arg)
(let-values (((type min max) (lookup-pre-type types label arg)))
(cond
((<= (target-most-negative-fixnum)
min max
(target-most-positive-fixnum))
'untag-fixnum)
((<= (- (ash 1 63)) min max (1- (ash 1 63)))
'scm->s64)
((<= 0 min max (1- (ash 1 64)))
'scm->u64)
(else (error "unreachable")))))
(define (integer-unbox-op/truncate arg)
(let-values (((type min max) (lookup-pre-type types label arg)))
(cond
((<= (target-most-negative-fixnum)
min max
(target-most-positive-fixnum))
'untag-fixnum)
((<= (- (ash 1 63)) min max (1- (ash 1 63)))
'scm->s64)
((<= 0 min max (1- (ash 1 64)))
'scm->u64)
(else
'scm->u64/truncate))))
(define (integer-box-op result)
(let-values (((type min max) (lookup-post-type types label result 0)))
(cond
((<= (target-most-negative-fixnum)
min max
(target-most-positive-fixnum))
'tag-fixnum)
((<= (- (ash 1 63)) min max (1- (ash 1 63)))
's64->scm)
(else
'u64->scm))))
(match cont (match cont
(($ $kfun) (($ $kfun)
(let ((types (infer-types cps label))) (let ((types (infer-types cps label)))
(values cps types (compute-significant-bits cps types label)))) (values cps types (compute-significant-bits cps types label))))
(($ $kargs names vars
($ $continue k src (($ $kargs names vars ($ $continue k src ($ $primcall op param args)))
($ $primcall (and op (or 'add 'sub 'mul 'div)) #f (a b)))) (values
(match (intmap-ref cps k) (match (intmap-ref cps k)
(($ $kargs (_) (result)) (($ $kargs (_) (result))
(call-with-values (lambda () (match (cons* op result param args)
(lookup-post-type types label result 0)) (((or 'add 'sub 'mul 'div)
(lambda (type min max) (? f64-result?) #f a b)
(values
(cond
((eqv? type &flonum)
(with-cps cps (with-cps cps
(let$ body (specialize-f64-binop k src op a b)) (let$ body (specialize-f64-binop k src op a b))
(setk label ($kargs names vars ,body)))) (setk label ($kargs names vars ,body))))
((and (type<=? type &exact-integer)
(or (<= 0 min max #xffffffffffffffff) (((or 'add 'sub 'mul)
(only-u64-bits-used? result)) (? u64-result?) #f (? u64-operand? a) (? u64-operand? b))
(u64-operand? a) (u64-operand? b)
(not (eq? op 'div)))
(with-cps cps (with-cps cps
(let$ body (specialize-u64-binop k src op a b)) (let$ body (specialize-u64-binop
k src op a b
#:unbox-a (integer-unbox-op a)
#:unbox-b (integer-unbox-op b)
#:box-result (integer-box-op result)))
(setk label ($kargs names vars ,body)))) (setk label ($kargs names vars ,body))))
(else
cps)) (((or 'add 'sub 'mul)
types (? s64-result?) #f (? s64-operand? a) (? s64-operand? b))
sigbits)))))) (with-cps cps
(($ $kargs names vars ;; "add", "sub", and "mul" behave the same for signed
($ $continue k src ;; and unsigned values, so we just use
($ $primcall (and op ;; specialize-u64-binop.
(or 'add/immediate 'sub/immediate (let$ body (specialize-u64-binop
'mul/immediate k src op a b
'rsh/immediate 'lsh/immediate)) #:unbox-a (integer-unbox-op a)
b (a)))) #:unbox-b (integer-unbox-op b)
(match (intmap-ref cps k) #:box-result (integer-box-op result)))
(($ $kargs (_) (result)) (setk label ($kargs names vars ,body))))
(call-with-values (lambda ()
(lookup-post-type types label result 0)) (((or 'add/immediate 'sub/immediate 'mul/immediate)
(lambda (type min max) (? f64-result?) b a)
(values
(cond
((eqv? type &flonum)
(with-cps cps (with-cps cps
(let$ body (specialize-f64-unop k src op a b)) (let$ body (specialize-f64-unop k src op a b))
(setk label ($kargs names vars ,body)))) (setk label ($kargs names vars ,body))))
((and (type<=? type &exact-integer)
(or (<= 0 min max #xffffffffffffffff) (((or 'add/immediate 'sub/immediate 'mul/immediate)
(only-u64-bits-used? result)) (? u64-result?) (? u64-parameter? b) (? u64-operand? a))
(u64-operand? a) (<= 0 b #xffffFFFFffffFFFF))
(with-cps cps (with-cps cps
(let$ body (specialize-u64-unop k src op a b)) (let$ body (specialize-u64-unop
k src op a b
#:unbox-a (integer-unbox-op a)
#:box-result (integer-box-op result)))
(setk label ($kargs names vars ,body)))) (setk label ($kargs names vars ,body))))
(else
cps)) (((or 'add/immediate 'sub/immediate 'mul/immediate)
(? s64-result?) (? s64-parameter? b) (? s64-operand? a))
(with-cps cps
(let$ body (specialize-s64-unop
k src op a b
#:unbox-a (integer-unbox-op a)
#:box-result (integer-box-op result)))
(setk label ($kargs names vars ,body))))
(((or 'lsh 'rsh)
(? u64-result?) #f (? u64-operand? a) b)
(with-cps cps
(let$ body (specialize-u64-shift
k src op a b
#:unbox-a (integer-unbox-op a)
#:box-result (integer-box-op result)))
(setk label ($kargs names vars ,body))))
(((or 'lsh/immediate 'rsh/immediate)
(? u64-result?) (? u6-parameter? b) (u64-operand? a))
(with-cps cps
(let$ body (specialize-u64-unop
k src op a param
#:unbox-a (integer-unbox-op a)
#:box-result (integer-box-op result)))
(setk label ($kargs names vars ,body))))
(((or 'lsh/immediate 'rsh/immediate)
(? s64-result?) (? u6-parameter? b) (s64-operand? a))
(with-cps cps
(let$ body (specialize-s64-unop
k src op a param
#:unbox-a (integer-unbox-op a)
#:box-result (integer-box-op result)))
(setk label ($kargs names vars ,body))))
;; FIXME: Should use logand/immediate for this special
;; case.
(('logand (? u64-result?) #f (? all-u64-bits-set?) b)
(with-cps cps
(let$ body (truncate-u64
k src b
#:unbox-a (integer-unbox-op/truncate b)
#:box-result (integer-box-op result)))
(setk label ($kargs names vars ,body))))
;; FIXME: Should use logand/immediate for this special
;; case.
(('logand (? u64-result?) #f a (? all-u64-bits-set?))
(with-cps cps
(let$ body (truncate-u64
k src a
#:unbox-a (integer-unbox-op/truncate a)
#:box-result (integer-box-op result)))
(setk label ($kargs names vars ,body))))
(((or 'logand 'logior 'logsub 'logxor)
(? u64-result?) #f a b)
(with-cps cps
(let$ body (specialize-u64-binop
k src op a b
#:unbox-a (integer-unbox-op/truncate a)
#:unbox-b (integer-unbox-op/truncate b)
#:box-result (integer-box-op result)))
(setk label ($kargs names vars ,body))))
(_ cps)))
(_ cps))
types types
sigbits)))))) sigbits))
(($ $kargs names vars
($ $continue k src
($ $primcall (and op (or 'lsh 'rsh)) (a b))))
(match (intmap-ref cps k)
(($ $kargs (_) (result))
(call-with-values (lambda ()
(lookup-pre-type types label b))
(lambda (b-type b-min b-max)
(values
(cond
((and (u64-result? result)
(u64-operand? a)
(<= b-max 63))
(with-cps cps
(let$ body (specialize-u64-shift k src op a b))
(setk label ($kargs names vars ,body))))
(else cps))
types
sigbits))))))
(($ $kargs names vars
($ $continue k src
($ $primcall (and op (or 'logand 'logior 'logsub 'logxor)) #f (a b))))
(match (intmap-ref cps k)
(($ $kargs (_) (result))
(values
(cond
((u64-result? result)
;; Given that we know the result can be unboxed to a u64,
;; any out-of-range bits won't affect the result and so we
;; can unconditionally project the operands onto u64.
(cond
((and (eq? op 'logand) (all-u64-bits-set? a))
(with-cps cps
(let$ body (truncate-u64 k src b))
(setk label ($kargs names vars ,body))))
((and (eq? op 'logand) (all-u64-bits-set? b))
(with-cps cps
(let$ body (truncate-u64 k src a))
(setk label ($kargs names vars ,body))))
(else
(with-cps cps
(let$ body (specialize-u64-binop k src op a b
#:unbox-a
'scm->u64/truncate
#:unbox-b
'scm->u64/truncate))
(setk label ($kargs names vars ,body))))))
(else cps))
types sigbits))))
(($ $kargs names vars (($ $kargs names vars
($ $continue k src ($ $continue k src
($ $branch kt ($ $primcall (and op (or '< '=)) #f (a b))))) ($ $branch kt ($ $primcall (and op (or '< '=)) #f (a b)))))
@ -540,20 +656,23 @@ 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))))
((and (u64-operand? a) (u64-operand? b)) ((fixnum-operand? a)
(with-cps cps (let ((specialize (if (fixnum-operand? b)
(let$ body (specialize-u64-comparison k kt src op a b)) specialize-fixnum-comparison
(setk label ($kargs names vars ,body)))) specialize-fixnum-scm-comparison)))
((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)))))
((s64-operand? b) ((fixnum-operand? b)
(with-cps cps (with-cps cps
(let$ body (specialize-scm-s64-comparison k kt src op a b)) (let$ body (specialize-scm-fixnum-comparison k kt src op a b))
(setk label ($kargs names vars ,body))))
((and (u64-operand? a) (u64-operand? b))
(with-cps cps
(let$ body (specialize-u64-comparison
k kt src op a b
#:unbox-a (integer-unbox-op/truncate a)
#:unbox-b (integer-unbox-op/truncate b)))
(setk label ($kargs names vars ,body)))) (setk label ($kargs names vars ,body))))
(else cps)) (else cps))
types types
@ -686,6 +805,27 @@ BITS indicating the significant bits needed for a variable. BITS may be
(compute-specializable-vars cps body preds defs exp-result-u64? (compute-specializable-vars cps body preds defs exp-result-u64?
'(scm->u64 'scm->u64/truncate))) '(scm->u64 'scm->u64/truncate)))
;; Compute vars whose definitions are all exact integers in the fixnum
;; range and whose uses include an untag operation.
(define (compute-specializable-fixnum-vars cps body preds defs)
;; Is the result of EXP definitely a fixnum?
(define (exp-result-fixnum? exp)
(match exp
((or ($ $primcall 'tag-fixnum #f (_))
($ $primcall 'tag-fixnum/unlikely #f (_))
($ $const (and (? number?) (? exact-integer?)
(? (lambda (n)
(<= (target-most-negative-fixnum)
n
(target-most-positive-fixnum)))))))
#t)
(_ #f)))
(compute-specializable-vars cps body preds defs exp-result-fixnum?
'(untag-fixnum
scm->s64
scm->u64 scm->u64/truncate)))
(define (compute-phi-vars cps preds) (define (compute-phi-vars cps preds)
(intmap-fold (lambda (label preds phis) (intmap-fold (lambda (label preds phis)
(match preds (match preds
@ -705,17 +845,25 @@ BITS indicating the significant bits needed for a variable. BITS may be
;; at least one use that is an unbox operation. ;; at least one use that is an unbox operation.
(define (compute-specializable-phis cps body preds defs) (define (compute-specializable-phis cps body preds defs)
(let ((f64-vars (compute-specializable-f64-vars cps body preds defs)) (let ((f64-vars (compute-specializable-f64-vars cps body preds defs))
(fixnum-vars (compute-specializable-fixnum-vars cps body preds defs))
(u64-vars (compute-specializable-u64-vars cps body preds defs)) (u64-vars (compute-specializable-u64-vars cps body preds defs))
(phi-vars (compute-phi-vars cps preds))) (phi-vars (compute-phi-vars cps preds)))
(unless (eq? empty-intset (intset-intersect f64-vars fixnum-vars))
(error "expected f64 and fixnum vars to be disjoint sets"))
(unless (eq? empty-intset (intset-intersect f64-vars u64-vars)) (unless (eq? empty-intset (intset-intersect f64-vars u64-vars))
(error "expected f64 and u64 vars to be disjoint sets")) (error "expected f64 and u64 vars to be disjoint sets"))
(intset-fold (lambda (var out) (intmap-add out var 'u64)) (intset-fold
(intset-intersect u64-vars phi-vars) (lambda (var out) (intmap-add out var 'u64))
(intset-fold (lambda (var out) (intmap-add out var 'f64)) (intset-subtract (intset-intersect u64-vars phi-vars) fixnum-vars)
(intset-fold
(lambda (var out) (intmap-add out var 'fx))
(intset-intersect fixnum-vars phi-vars)
(intset-fold
(lambda (var out) (intmap-add out var 'f64))
(intset-intersect f64-vars phi-vars) (intset-intersect f64-vars phi-vars)
empty-intmap)))) empty-intmap)))))
;; Each definition of an f64/u64 variable should unbox that variable. ;; Each definition of an f64/fx/u64 variable should unbox that variable.
;; The cont that binds the variable should re-box it under its original ;; The cont that binds the variable should re-box it under its original
;; name, and rely on CSE to remove the boxing as appropriate. ;; name, and rely on CSE to remove the boxing as appropriate.
(define (apply-specialization cps kfun body preds defs phis) (define (apply-specialization cps kfun body preds defs phis)
@ -729,10 +877,12 @@ BITS indicating the significant bits needed for a variable. BITS may be
(define (unbox-op var) (define (unbox-op var)
(match (intmap-ref phis var) (match (intmap-ref phis var)
('f64 'scm->f64) ('f64 'scm->f64)
('fx 'untag-fixnum)
('u64 'scm->u64))) ('u64 'scm->u64)))
(define (box-op var) (define (box-op var)
(match (intmap-ref phis var) (match (intmap-ref phis var)
('f64 'f64->scm) ('f64 'f64->scm)
('fx 'tag-fixnum)
('u64 'u64->scm))) ('u64 'u64->scm)))
(define (unbox-operands) (define (unbox-operands)
(define (unbox-arg cps arg def-var have-arg) (define (unbox-arg cps arg def-var have-arg)

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

@ -79,7 +79,8 @@
(('scm->f64 (? f64? var)) (load-f64 var ())) (('scm->f64 (? f64? var)) (load-f64 var ()))
(('scm->u64 (? u64? var)) (load-u64 var ())) (('scm->u64 (? u64? var)) (load-u64 var ()))
(('scm->u64/truncate (? u64? var)) (load-u64 var ())) (('scm->u64/truncate (? u64? var)) (load-u64 var ()))
(('scm->s64 (? s64? var)) (load-s64 var ())))) (('scm->s64 (? s64? var)) (load-s64 var ()))
(('untag-fixnum (? s64? var)) (load-s64 var ()))))
(intmap-map (intmap-map
(lambda (label cont) (lambda (label cont)
(match cont (match cont

41
module/language/cps/type-fold.scm
View file

@ -346,6 +346,47 @@
($ (convert-to-logtest kbool))))) ($ (convert-to-logtest kbool)))))
(with-cps cps #f))) (with-cps cps #f)))
(define-unary-primcall-reducer (u64->scm cps k src constant arg type min max)
(cond
((<= max (target-most-positive-fixnum))
(with-cps cps
(build-term
($continue k src
($primcall 'tag-fixnum #f (arg))))))
(else
(with-cps cps #f))))
(define-unary-primcall-reducer (s64->scm cps k src constant arg type min max)
(cond
((<= max (target-most-positive-fixnum))
(with-cps cps
(build-term
($continue k src
($primcall 'tag-fixnum #f (arg))))))
(else
(with-cps cps #f))))
(define-unary-primcall-reducer (scm->s64 cps k src constant arg type min max)
(cond
((and (type<=? type &exact-integer)
(<= (target-most-negative-fixnum) min max (target-most-positive-fixnum)))
(with-cps cps
(build-term
($continue k src
($primcall 'untag-fixnum #f (arg))))))
(else
(with-cps cps #f))))
(define-unary-primcall-reducer (scm->u64 cps k src constant arg type min max)
(cond
((and (type<=? type &exact-integer)
(<= 0 min max (target-most-positive-fixnum)))
(with-cps cps
(build-term
($continue k src
($primcall 'untag-fixnum #f (arg))))))
(else
(with-cps cps #f))))

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

@ -912,13 +912,12 @@ minimum, and maximum."
(define-type-inferrer/param (load-s64 param result) (define-type-inferrer/param (load-s64 param result)
(define! result &s64 param param)) (define! result &s64 param param))
(define-simple-type-checker (untag-fixnum &fixnum))
(define-type-inferrer (untag-fixnum scm result) (define-type-inferrer (untag-fixnum scm result)
(define! result &s64 (&min/s64 scm) (&max/s64 scm))) (define! result &s64 (&min/s64 scm) (&max/s64 scm)))
(define-simple-type-checker (tag-fixnum (logior &s64 &u64)))
(define-type-inferrer (tag-fixnum s64 result) (define-type-inferrer (tag-fixnum s64 result)
(define! result &fixnum (&min/fixnum s64) (&max/fixnum s64))) (define! result &fixnum (&min/fixnum s64) (&max/fixnum s64)))
(define-type-aliases tag-fixnum tag-fixnum/unlikely)