[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 04/04: Better untagging of fixnums
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 04/04: Better untagging of fixnums |
|
Date: |
Mon, 13 Nov 2017 09:27:16 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit 7e79a3291e10ce6e273888799355f353db284d8e
Author: Andy Wingo <address@hidden>
Date: Mon Nov 13 14:39:30 2017 +0100
Better untagging of fixnums
* 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.
---
module/language/cps/compile-bytecode.scm | 2 +-
module/language/cps/cse.scm | 7 +
module/language/cps/effects-analysis.scm | 3 +-
module/language/cps/primitives.scm | 1 +
module/language/cps/specialize-numbers.scm | 476 ++++++++++++++++++---------
module/language/cps/specialize-primcalls.scm | 3 +-
module/language/cps/type-fold.scm | 41 +++
module/language/cps/types.scm | 3 +-
8 files changed, 368 insertions(+), 168 deletions(-)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 6be05c7..429f7e7 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -273,7 +273,7 @@
(from-sp (slot expected)) (from-sp (slot desired))))
(($ $primcall 'untag-fixnum #f (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))))
(($ $primcall name #f args)
;; FIXME: Inline all the cases.
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index b4b23ed..9d38c3a 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -334,6 +334,13 @@ false. It could be that both true and false proofs are
available."
((s64)
(add-def! `(primcall s64->scm #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))))
(define (visit-label label equiv-labels var-substs)
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 29b36c6..dd24e73 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -375,7 +375,8 @@ is or might be a read or a write to the same location as A."
((s64->scm _))
((s64->scm/unlikely _))
((untag-fixnum _))
- ((tag-fixnum _)))
+ ((tag-fixnum _))
+ ((tag-fixnum/unlikely _)))
;; Bytevectors.
(define-primitive-effects
diff --git a/module/language/cps/primitives.scm
b/module/language/cps/primitives.scm
index d9a6d58..ed1492f 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -68,6 +68,7 @@
(define *macro-instruction-arities*
'((u64->scm/unlikely . (1 . 1))
(s64->scm/unlikely . (1 . 1))
+ (tag-fixnum/unlikely . (1 . 1))
(cache-current-module! . (0 . 1))
(cached-toplevel-box . (1 . 0))
(cached-module-box . (1 . 0))))
diff --git a/module/language/cps/specialize-numbers.scm
b/module/language/cps/specialize-numbers.scm
index 16e0df1..37a1705 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -52,6 +52,7 @@
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
+ #:use-module (system base target)
#:use-module (language cps)
#:use-module (language cps intmap)
#:use-module (language cps intset)
@@ -82,7 +83,8 @@
($primcall 'scm->f64 #f (a)))))))))
(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
('add/immediate 'uadd/immediate)
('sub/immediate 'usub/immediate)
@@ -93,7 +95,7 @@
(letv u64-a result)
(letk kbox ($kargs ('result) (result)
($continue k src
- ($primcall 'u64->scm #f (result)))))
+ ($primcall box-result #f (result)))))
(letk kop ($kargs ('u64-a) (u64-a)
($continue kbox src
($primcall uop b (u64-a)))))
@@ -101,6 +103,27 @@
($continue kop src
($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)
(let ((fop (match op
('add 'fadd)
@@ -124,7 +147,8 @@
(define* (specialize-u64-binop cps k src op a b #:key
(unbox-a 'scm->u64)
- (unbox-b 'scm->u64))
+ (unbox-b 'scm->u64)
+ (box-result 'u64->scm))
(let ((uop (match op
('add 'uadd)
('sub 'usub)
@@ -137,7 +161,7 @@
(letv u64-a u64-b result)
(letk kbox ($kargs ('result) (result)
($continue k src
- ($primcall 'u64->scm #f (result)))))
+ ($primcall box-result #f (result)))))
(letk kop ($kargs ('u64-b) (u64-b)
($continue kbox src
($primcall uop #f (u64-a u64-b)))))
@@ -149,7 +173,8 @@
($primcall unbox-a #f (a)))))))
(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
('rsh 'ursh)
('lsh 'ulsh))))
@@ -157,7 +182,7 @@
(letv u64-a result)
(letk kbox ($kargs ('result) (result)
($continue k src
- ($primcall 'u64->scm #f (result)))))
+ ($primcall box-result #f (result)))))
(letk kop ($kargs ('u64-a) (u64-a)
($continue kbox src
($primcall uop #f (u64-a b)))))
@@ -165,31 +190,19 @@
($continue kop src
($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
(letv u64)
(letk kbox ($kargs ('u64) (u64)
($continue k src
- ($primcall 'u64->scm #f (u64)))))
+ ($primcall box-result #f (u64)))))
(build-term
($continue kbox src
- ($primcall 'scm->u64/truncate #f (scm))))))
-
-(define (specialize-u64-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)))))))
+ ($primcall unbox-a #f (scm))))))
-(define (specialize-s64-comparison cps kf kt src op a b)
+(define (specialize-fixnum-comparison cps kf kt src op a b)
(let ((op (symbol-append 's64- op)))
(with-cps cps
(letv s64-a s64-b)
@@ -198,12 +211,12 @@
($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)))))
+ ($primcall 'untag-fixnum #f (b)))))
(build-term
($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-<))))
(with-cps cps
(letv a b sunk)
@@ -212,11 +225,11 @@
($branch kt ($primcall op #f (sunk b-scm))))))
;; Re-box the variable. FIXME: currently we use a specially
;; 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..
(letk kretag ($kargs () ()
($continue kheap src
- ($primcall 's64->scm/unlikely #f (a)))))
+ ($primcall 'tag-fixnum/unlikely #f (a)))))
(letk kb ($kargs ('b) (b)
($continue kf src
($branch kt ($primcall s64-op #f (a b))))))
@@ -228,11 +241,11 @@
($branch kfix ($primcall 'fixnum? #f (b-scm))))))
(build-term
($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
- ('= (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
(letv a b sunk)
@@ -241,11 +254,11 @@
($branch kt ($primcall '< #f (a-scm sunk))))))
;; Re-box the variable. FIXME: currently we use a specially
;; 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..
(letk kretag ($kargs () ()
($continue kheap src
- ($primcall 's64->scm/unlikely #f (b)))))
+ ($primcall 'tag-fixnum/unlikely #f (b)))))
(letk ka ($kargs ('a) (a)
($continue kf src
($branch kt ($primcall 's64-< #f (a b))))))
@@ -257,7 +270,23 @@
($branch kfix ($primcall 'fixnum? #f (a-scm))))))
(build-term
($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)
(let ((op (symbol-append 'f64- op)))
@@ -391,6 +420,12 @@ BITS indicating the significant bits needed for a
variable. BITS may be
(_ out)))))))))
(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 (operand-in-range? var &type &min &max)
(call-with-values (lambda ()
@@ -398,17 +433,31 @@ BITS indicating the significant bits needed for a
variable. BITS may be
(lambda (type min max)
(and (type<=? type &type) (<= &min min max &max)))))
(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)
+ (operand-in-range? var &exact-integer (ash -1 63) (1- (ash 1 63))))
+ (define (fixnum-operand? var)
(operand-in-range? var &exact-integer
- (- #x8000000000000000) #x7fffffffffffffff))
+ (target-most-negative-fixnum)
+ (target-most-positive-fixnum)))
(define (all-u64-bits-set? var)
- (operand-in-range? var &exact-integer
- #xffffffffffffffff
- #xffffffffffffffff))
+ (operand-in-range? var &exact-integer (1- (ash 1 64)) (1- (ash 1 64))))
+ (define (only-fixnum-bits-used? var)
+ (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)
(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)
(or (only-u64-bits-used? result)
(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))
(lambda (type min max)
(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)
(let-values (((typea mina maxa) (lookup-pre-type types label vara))
((typeb minb maxb) (lookup-pre-type types label varb)))
(and (zero? (logand (logior typea typeb) (lognot &real)))
(or (eqv? typea &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
(($ $kfun)
(let ((types (infer-types cps label)))
(values cps types (compute-significant-bits cps types label))))
- (($ $kargs names vars
- ($ $continue k src
- ($ $primcall (and op (or 'add 'sub 'mul 'div)) #f (a b))))
- (match (intmap-ref cps k)
- (($ $kargs (_) (result))
- (call-with-values (lambda ()
- (lookup-post-type types label result 0))
- (lambda (type min max)
- (values
- (cond
- ((eqv? type &flonum)
- (with-cps cps
- (let$ body (specialize-f64-binop k src op a b))
- (setk label ($kargs names vars ,body))))
- ((and (type<=? type &exact-integer)
- (or (<= 0 min max #xffffffffffffffff)
- (only-u64-bits-used? result))
- (u64-operand? a) (u64-operand? b)
- (not (eq? op 'div)))
- (with-cps cps
- (let$ body (specialize-u64-binop 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 'add/immediate 'sub/immediate
- 'mul/immediate
- 'rsh/immediate 'lsh/immediate))
- b (a))))
- (match (intmap-ref cps k)
- (($ $kargs (_) (result))
- (call-with-values (lambda ()
- (lookup-post-type types label result 0))
- (lambda (type min max)
- (values
- (cond
- ((eqv? type &flonum)
- (with-cps cps
- (let$ body (specialize-f64-unop k src op a b))
- (setk label ($kargs names vars ,body))))
- ((and (type<=? type &exact-integer)
- (or (<= 0 min max #xffffffffffffffff)
- (only-u64-bits-used? result))
- (u64-operand? a) (<= 0 b #xffffFFFFffffFFFF))
- (with-cps cps
- (let$ body (specialize-u64-unop 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 '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 ($ $continue k src ($ $primcall op param args)))
+ (values
+ (match (intmap-ref cps k)
+ (($ $kargs (_) (result))
+ (match (cons* op result param args)
+ (((or 'add 'sub 'mul 'div)
+ (? f64-result?) #f a b)
+ (with-cps cps
+ (let$ body (specialize-f64-binop k src op a b))
+ (setk label ($kargs names vars ,body))))
+
+ (((or 'add 'sub 'mul)
+ (? u64-result?) #f (? u64-operand? a) (? u64-operand? b))
+ (with-cps cps
+ (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))))
+
+ (((or 'add 'sub 'mul)
+ (? s64-result?) #f (? s64-operand? a) (? s64-operand? b))
+ (with-cps cps
+ ;; "add", "sub", and "mul" behave the same for signed
+ ;; and unsigned values, so we just use
+ ;; specialize-u64-binop.
+ (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))))
+
+ (((or 'add/immediate 'sub/immediate 'mul/immediate)
+ (? f64-result?) b a)
+ (with-cps cps
+ (let$ body (specialize-f64-unop k src op a b))
+ (setk label ($kargs names vars ,body))))
+
+ (((or 'add/immediate 'sub/immediate 'mul/immediate)
+ (? u64-result?) (? u64-parameter? b) (? u64-operand? a))
+ (with-cps cps
+ (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))))
+
+ (((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
+ sigbits))
+
(($ $kargs names vars
($ $continue k src
($ $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
(let$ body (specialize-f64-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))
- (setk label ($kargs names vars ,body))))
- ((s64-operand? a)
- (let ((specialize (if (s64-operand? b)
- specialize-s64-comparison
- specialize-s64-scm-comparison)))
+ ((fixnum-operand? a)
+ (let ((specialize (if (fixnum-operand? b)
+ specialize-fixnum-comparison
+ specialize-fixnum-scm-comparison)))
(with-cps cps
(let$ body (specialize k kt src op a b))
(setk label ($kargs names vars ,body)))))
- ((s64-operand? b)
+ ((fixnum-operand? b)
(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))))
(else cps))
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?
'(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)
(intmap-fold (lambda (label preds phis)
(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.
(define (compute-specializable-phis 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))
(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))
(error "expected f64 and u64 vars to be disjoint sets"))
- (intset-fold (lambda (var out) (intmap-add out var 'u64))
- (intset-intersect u64-vars phi-vars)
- (intset-fold (lambda (var out) (intmap-add out var 'f64))
- (intset-intersect f64-vars phi-vars)
- empty-intmap))))
-
-;; Each definition of an f64/u64 variable should unbox that variable.
+ (intset-fold
+ (lambda (var out) (intmap-add out var 'u64))
+ (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)
+ empty-intmap)))))
+
+;; 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
;; name, and rely on CSE to remove the boxing as appropriate.
(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)
(match (intmap-ref phis var)
('f64 'scm->f64)
+ ('fx 'untag-fixnum)
('u64 'scm->u64)))
(define (box-op var)
(match (intmap-ref phis var)
('f64 'f64->scm)
+ ('fx 'tag-fixnum)
('u64 'u64->scm)))
(define (unbox-operands)
(define (unbox-arg cps arg def-var have-arg)
diff --git a/module/language/cps/specialize-primcalls.scm
b/module/language/cps/specialize-primcalls.scm
index b26eb16..eedc28b 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -79,7 +79,8 @@
(('scm->f64 (? f64? var)) (load-f64 var ()))
(('scm->u64 (? 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
(lambda (label cont)
(match cont
diff --git a/module/language/cps/type-fold.scm
b/module/language/cps/type-fold.scm
index bf016ec..999bb5f 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -346,6 +346,47 @@
($ (convert-to-logtest kbool)))))
(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))))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 9e370f7..7dcafd6 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -912,13 +912,12 @@ minimum, and maximum."
(define-type-inferrer/param (load-s64 param result)
(define! result &s64 param param))
-(define-simple-type-checker (untag-fixnum &fixnum))
(define-type-inferrer (untag-fixnum scm result)
(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! result &fixnum (&min/fixnum s64) (&max/fixnum s64)))
+(define-type-aliases tag-fixnum tag-fixnum/unlikely)