[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/04: Refactor number specialization to reduce duplicat
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 02/04: Refactor number specialization to reduce duplication |
|
Date: |
Sat, 2 Dec 2017 15:15:41 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit 8c37cf083f892b4a72b13f664243215af8dc3e74
Author: Andy Wingo <address@hidden>
Date: Sat Dec 2 11:43:44 2017 +0100
Refactor number specialization to reduce duplication
* module/language/cps/specialize-numbers.scm (specialize-operations):
Factor out specialize-primcall and specialize-branch operations.
---
module/language/cps/specialize-numbers.scm | 464 +++++++++++++----------------
1 file changed, 209 insertions(+), 255 deletions(-)
diff --git a/module/language/cps/specialize-numbers.scm
b/module/language/cps/specialize-numbers.scm
index 7df5f2a..5b0103f 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -451,266 +451,220 @@ BITS indicating the significant bits needed for a
variable. BITS may be
(define (box-f64 result)
f64->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 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)
- (let ((op (match op
- ('add 'fadd) ('sub 'fsub) ('mul 'fmul) ('div
'fdiv))))
- (with-cps cps
- (let$ body (specialize-binop
- k src op a b
- (unbox-f64 a) (unbox-f64 b) (box-f64 result)))
- ;; FIXME: Remove this repetition.
- (setk label ($kargs names vars ,body)))))
-
- (((or 'add 'sub 'mul 'logand 'logior 'logxor 'logsub)
- (? u64-result?) #f (? u64-operand? a) (? u64-operand? b))
- (let ((op (match op
- ('add 'uadd) ('sub 'usub) ('mul 'umul)
- ('logand 'ulogand) ('logior 'ulogior)
- ('logxor 'ulogxor) ('logsub 'ulogsub))))
- (with-cps cps
- (let$ body (specialize-binop
- k src op a b
- (unbox-u64 a) (unbox-u64 b) (box-u64 result)))
- (setk label ($kargs names vars ,body)))))
-
- (((or 'logand 'logior 'logxor 'logsub)
- (? u64-result?) #f (? s64-operand? a) (? s64-operand? b))
- (let ((op (match op
- ('logand 'ulogand) ('logior 'ulogior)
- ('logxor 'ulogxor) ('logsub 'ulogsub))))
- (define (unbox-u64* x)
- (let ((unbox-s64 (unbox-s64 x)))
- (lambda (cps k src x)
- (with-cps cps
- (letv s64)
- (letk ks64 ($kargs ('s64) (s64)
- ($continue k src
- ($primcall 's64->u64 #f (s64)))))
- ($ (unbox-s64 k src x))))))
- (with-cps cps
- (let$ body (specialize-binop
- k src op a b
- (unbox-u64* a) (unbox-u64* b) (box-u64 result)))
- (setk label ($kargs names vars ,body)))))
-
- (((or 'add 'sub 'mul)
- (? s64-result?) #f (? s64-operand? a) (? s64-operand? b))
- (let ((op (match op
- ('add 'sadd) ('sub 'ssub) ('mul 'smul))))
- (with-cps cps
- (let$ body (specialize-binop
- k src op a b
- (unbox-s64 a) (unbox-s64 b) (box-s64 result)))
- (setk label ($kargs names vars ,body)))))
-
- (('sub/immediate
- (? f64-result?) param a)
- (with-cps cps
- (let$ body (specialize-unop
- k src 'fadd/immediate (- param) a
- (unbox-f64 a) (box-f64 result)))
- (setk label ($kargs names vars ,body))))
-
- (((or 'add/immediate 'mul/immediate)
- (? f64-result?) param a)
- (let ((op (match op
- ('add/immediate 'fadd/immediate)
- ('mul/immediate 'fmul/immediate))))
- (with-cps cps
- (let$ body (specialize-unop
- k src op param a
- (unbox-f64 a) (box-f64 result)))
- (setk label ($kargs names vars ,body)))))
-
- (((or 'add/immediate 'sub/immediate 'mul/immediate)
- (? u64-result?) (? u64-parameter?) (? u64-operand? a))
- (let ((op (match op
- ('add/immediate 'uadd/immediate)
- ('sub/immediate 'usub/immediate)
- ('mul/immediate 'umul/immediate))))
- (with-cps cps
- (let$ body (specialize-unop
- k src op param a
- (unbox-u64 a) (box-u64 result)))
- (setk label ($kargs names vars ,body)))))
-
- (((or 'add/immediate 'sub/immediate 'mul/immediate)
- (? s64-result?) (? s64-parameter?) (? s64-operand? a))
- (let ((op (match op
- ('add/immediate 'sadd/immediate)
- ('sub/immediate 'ssub/immediate)
- ('mul/immediate 'smul/immediate))))
- (with-cps cps
- (let$ body (specialize-unop
- k src op param a
- (unbox-s64 a) (box-s64 result)))
- (setk label ($kargs names vars ,body)))))
-
- (((or 'lsh 'rsh)
- (? u64-result?) #f (? u64-operand? a) (? u6-operand? b))
- (let ((op (match op ('lsh 'ulsh) ('rsh 'ursh))))
- (define (pass-u64 cps k src b)
- (with-cps cps
- (build-term ($continue k src ($values (b))))))
- (with-cps cps
- (let$ body (specialize-binop
- k src op a b
- (unbox-u64 a) pass-u64 (box-u64 result)))
- (setk label ($kargs names vars ,body)))))
-
- (((or 'lsh 'rsh)
- (? s64-result?) #f (? s64-operand? a) (? u6-operand? b))
- (let ((op (match op ('lsh 'slsh) ('rsh 'srsh))))
- (define (pass-u64 cps k src b)
- (with-cps cps
- (build-term ($continue k src ($values (b))))))
- (with-cps cps
- (let$ body (specialize-binop
- k src op a b
- (unbox-s64 a) pass-u64 (box-s64 result)))
- (setk label ($kargs names vars ,body)))))
-
- (((or 'lsh/immediate 'rsh/immediate)
- (? u64-result?) (? u6-parameter?) (? u64-operand? a))
- (let ((op (match op
- ('lsh/immediate 'ulsh/immediate)
- ('rsh/immediate 'ursh/immediate))))
+ (define (specialize-primcall cps k src op param args)
+ (match (intmap-ref cps k)
+ (($ $kargs (_) (result))
+ (match (cons* op result param args)
+ (((or 'add 'sub 'mul 'div)
+ (? f64-result?) #f a b)
+ (let ((op (match op
+ ('add 'fadd) ('sub 'fsub) ('mul 'fmul) ('div 'fdiv))))
+ (specialize-binop cps k src op a b
+ (unbox-f64 a) (unbox-f64 b) (box-f64 result))))
+
+ (((or 'add 'sub 'mul 'logand 'logior 'logxor 'logsub)
+ (? u64-result?) #f (? u64-operand? a) (? u64-operand? b))
+ (let ((op (match op
+ ('add 'uadd) ('sub 'usub) ('mul 'umul)
+ ('logand 'ulogand) ('logior 'ulogior)
+ ('logxor 'ulogxor) ('logsub 'ulogsub))))
+ (specialize-binop cps k src op a b
+ (unbox-u64 a) (unbox-u64 b) (box-u64 result))))
+
+ (((or 'logand 'logior 'logxor 'logsub)
+ (? u64-result?) #f (? s64-operand? a) (? s64-operand? b))
+ (let ((op (match op
+ ('logand 'ulogand) ('logior 'ulogior)
+ ('logxor 'ulogxor) ('logsub 'ulogsub))))
+ (define (unbox-u64* x)
+ (let ((unbox-s64 (unbox-s64 x)))
+ (lambda (cps k src x)
+ (with-cps cps
+ (letv s64)
+ (letk ks64 ($kargs ('s64) (s64)
+ ($continue k src
+ ($primcall 's64->u64 #f
(s64)))))
+ ($ (unbox-s64 k src x))))))
+ (specialize-binop cps k src op a b
+ (unbox-u64* a) (unbox-u64* b) (box-u64
result))))
+
+ (((or 'add 'sub 'mul)
+ (? s64-result?) #f (? s64-operand? a) (? s64-operand? b))
+ (let ((op (match op
+ ('add 'sadd) ('sub 'ssub) ('mul 'smul))))
+ (specialize-binop cps k src op a b
+ (unbox-s64 a) (unbox-s64 b) (box-s64 result))))
+
+ (('sub/immediate
+ (? f64-result?) param a)
+ (specialize-unop cps k src 'fadd/immediate (- param) a
+ (unbox-f64 a) (box-f64 result)))
+
+ (((or 'add/immediate 'mul/immediate)
+ (? f64-result?) param a)
+ (let ((op (match op
+ ('add/immediate 'fadd/immediate)
+ ('mul/immediate 'fmul/immediate))))
+ (specialize-unop cps k src op param a
+ (unbox-f64 a) (box-f64 result))))
+
+ (((or 'add/immediate 'sub/immediate 'mul/immediate)
+ (? u64-result?) (? u64-parameter?) (? u64-operand? a))
+ (let ((op (match op
+ ('add/immediate 'uadd/immediate)
+ ('sub/immediate 'usub/immediate)
+ ('mul/immediate 'umul/immediate))))
+ (specialize-unop cps k src op param a
+ (unbox-u64 a) (box-u64 result))))
+
+ (((or 'add/immediate 'sub/immediate 'mul/immediate)
+ (? s64-result?) (? s64-parameter?) (? s64-operand? a))
+ (let ((op (match op
+ ('add/immediate 'sadd/immediate)
+ ('sub/immediate 'ssub/immediate)
+ ('mul/immediate 'smul/immediate))))
+ (specialize-unop cps k src op param a
+ (unbox-s64 a) (box-s64 result))))
+
+ (((or 'lsh 'rsh)
+ (? u64-result?) #f (? u64-operand? a) (? u6-operand? b))
+ (let ((op (match op ('lsh 'ulsh) ('rsh 'ursh))))
+ (define (pass-u64 cps k src b)
(with-cps cps
- (let$ body (specialize-unop
- k src op param a
- (unbox-u64 a) (box-u64 result)))
- (setk label ($kargs names vars ,body)))))
-
- (((or 'lsh/immediate 'rsh/immediate)
- (? s64-result?) (? u6-parameter?) (? s64-operand? a))
- (let ((op (match op
- ('lsh/immediate 'slsh/immediate)
- ('rsh/immediate 'srsh/immediate))))
+ (build-term ($continue k src ($values (b))))))
+ (specialize-binop cps k src op a b
+ (unbox-u64 a) pass-u64 (box-u64 result))))
+
+ (((or 'lsh 'rsh)
+ (? s64-result?) #f (? s64-operand? a) (? u6-operand? b))
+ (let ((op (match op ('lsh 'slsh) ('rsh 'srsh))))
+ (define (pass-u64 cps k src b)
(with-cps cps
- (let$ body (specialize-unop
- k src op param a
- (unbox-s64 a) (box-s64 result)))
- (setk label ($kargs names vars ,body)))))
+ (build-term ($continue k src ($values (b))))))
+ (specialize-binop cps k src op a b
+ (unbox-s64 a) pass-u64 (box-s64 result))))
+
+ (((or 'lsh/immediate 'rsh/immediate)
+ (? u64-result?) (? u6-parameter?) (? u64-operand? a))
+ (let ((op (match op
+ ('lsh/immediate 'ulsh/immediate)
+ ('rsh/immediate 'ursh/immediate))))
+ (specialize-unop cps k src op param a
+ (unbox-u64 a) (box-u64 result))))
+
+ (((or 'lsh/immediate 'rsh/immediate)
+ (? s64-result?) (? u6-parameter?) (? s64-operand? a))
+ (let ((op (match op
+ ('lsh/immediate 'slsh/immediate)
+ ('rsh/immediate 'srsh/immediate))))
+ (specialize-unop cps k src op param a
+ (unbox-s64 a) (box-s64 result))))
+
+ (_ (with-cps cps #f))))
+ (_ (with-cps cps #f))))
+
+ (define (specialize-branch cps kf kt src op param args)
+ (match (cons op args)
+ (((or '< '=) a b)
+ (cond
+ ((f64-operands? a b)
+ (let ((op (match op ('= 'f64-=) ('< 'f64-<))))
+ (specialize-comparison cps kf kt src op a b
+ (unbox-f64 a) (unbox-f64 b))))
+ ((and (s64-operand? a) (s64-operand? b))
+ (cond
+ ((constant-arg a)
+ => (lambda (a)
+ (let ((op (match op ('= 's64-imm-=) ('< 'imm-s64-<))))
+ (specialize-comparison/immediate cps kf kt src op b a
+ (unbox-s64 b)))))
+ ((constant-arg b)
+ => (lambda (b)
+ (let ((op (match op ('= 's64-imm-=) ('< 's64-imm-<))))
+ (specialize-comparison/immediate cps kf kt src op a b
+ (unbox-s64 a)))))
+ (else
+ (let ((op (match op ('= 's64-=) ('< 's64-<))))
+ (specialize-comparison cps kf kt src op a b
+ (unbox-s64 a) (unbox-s64 b))))))
+ ((and (u64-operand? a) (u64-operand? b))
+ (cond
+ ((constant-arg a)
+ => (lambda (a)
+ (let ((op (match op ('= 'u64-imm-=) ('< 'imm-u64-<))))
+ (specialize-comparison/immediate cps kf kt src op b a
+ (unbox-u64 b)))))
+ ((constant-arg b)
+ => (lambda (b)
+ (let ((op (match op ('= 'u64-imm-=) ('< 'u64-imm-<))))
+ (specialize-comparison/immediate cps kf kt src op a b
+ (unbox-u64 a)))))
+ (else
+ (let ((op (match op ('= 'u64-=) ('< 'u64-<))))
+ (specialize-comparison cps kf kt src op a b
+ (unbox-u64 a) (unbox-u64 b))))))
+ ((and (exact-integer-operand? a) (exact-integer-operand? b))
+ (cond
+ ((s64-operand? a)
+ (cond
+ ((constant-arg a)
+ => (lambda (a)
+ (let ((imm-op (match op ('= 's64-imm-=) ('< 'imm-s64-<))))
+ (specialize-comparison/immediate-s64-integer
+ cps kf kt src imm-op a b
+ (lambda (cps a)
+ (with-cps cps
+ (build-exp ($primcall op #f (a b)))))))))
+ (else
+ (specialize-comparison/s64-integer cps kf kt src op a b
+ (unbox-s64 a)
+ (rebox-s64 a)))))
+ ((s64-operand? b)
+ (cond
+ ((constant-arg b)
+ => (lambda (b)
+ (let ((imm-op (match op ('= 's64-imm-=) ('< 's64-imm-<))))
+ (specialize-comparison/immediate-s64-integer
+ cps kf kt src imm-op b a
+ (lambda (cps b)
+ (with-cps cps
+ (build-exp ($primcall op #f (a b)))))))))
+ (else
+ (specialize-comparison/integer-s64 cps kf kt src op a b
+ (unbox-s64 b)
+ (rebox-s64 b)))))
+ (else (with-cps cps #f))))
+ (else (with-cps cps #f))))
+ (_ (with-cps cps #f))))
- (_ cps)))
- (_ cps))
- types
- sigbits))
+ (match cont
+ (($ $kfun)
+ (let* ((types (infer-types cps label))
+ (sigbits (compute-significant-bits cps types label)))
+ (values cps types sigbits)))
(($ $kargs names vars
- ($ $continue kf src
- ($ $branch kt ($ $primcall (and op (or '< '=)) #f (a b)))))
- (values
- (cond
- ((f64-operands? a b)
- (let ((op (match op ('= 'f64-=) ('< 'f64-<))))
- (with-cps cps
- (let$ body (specialize-comparison kf kt src op a b
- (unbox-f64 a) (unbox-f64 b)))
- (setk label ($kargs names vars ,body)))))
- ((and (s64-operand? a) (s64-operand? b))
- (cond
- ((constant-arg a)
- => (lambda (a)
- (let ((op (match op ('= 's64-imm-=) ('< 'imm-s64-<))))
- (with-cps cps
- (let$ body (specialize-comparison/immediate
- kf kt src op b a
- (unbox-s64 b)))
- (setk label ($kargs names vars ,body))))))
- ((constant-arg b)
- => (lambda (b)
- (let ((op (match op ('= 's64-imm-=) ('< 's64-imm-<))))
- (with-cps cps
- (let$ body (specialize-comparison/immediate
- kf kt src op a b
- (unbox-s64 a)))
- (setk label ($kargs names vars ,body))))))
- (else
- (let ((op (match op ('= 's64-=) ('< 's64-<))))
- (with-cps cps
- (let$ body (specialize-comparison
- kf kt src op a b
- (unbox-s64 a) (unbox-s64 b)))
- (setk label ($kargs names vars ,body)))))))
- ((and (u64-operand? a) (u64-operand? b))
- (cond
- ((constant-arg a)
- => (lambda (a)
- (let ((op (match op ('= 'u64-imm-=) ('< 'imm-u64-<))))
- (with-cps cps
- (let$ body (specialize-comparison/immediate
- kf kt src op b a
- (unbox-u64 b)))
- (setk label ($kargs names vars ,body))))))
- ((constant-arg b)
- => (lambda (b)
- (let ((op (match op ('= 'u64-imm-=) ('< 'u64-imm-<))))
- (with-cps cps
- (let$ body (specialize-comparison/immediate
- kf kt src op a b
- (unbox-u64 a)))
- (setk label ($kargs names vars ,body))))))
- (else
- (let ((op (match op ('= 'u64-=) ('< 'u64-<))))
- (with-cps cps
- (let$ body (specialize-comparison
- kf kt src op a b
- (unbox-u64 a) (unbox-u64 b)))
- (setk label ($kargs names vars ,body)))))))
- ((and (exact-integer-operand? a) (exact-integer-operand? b))
- (cond
- ((s64-operand? a)
- (cond
- ((constant-arg a)
- => (lambda (a)
- (let ((imm-op (match op ('= 's64-imm-=) ('< 'imm-s64-<))))
- (with-cps cps
- (let$ body (specialize-comparison/immediate-s64-integer
- kf kt src imm-op a b
- (lambda (cps a)
- (with-cps cps
- (build-exp ($primcall op #f (a b)))))))
- (setk label ($kargs names vars ,body))))))
- (else
- (with-cps cps
- (let$ body (specialize-comparison/s64-integer
- kf kt src op a b
- (unbox-s64 a) (rebox-s64 a)))
- (setk label ($kargs names vars ,body))))))
- ((s64-operand? b)
- (cond
- ((constant-arg b)
- => (lambda (b)
- (let ((imm-op (match op ('= 's64-imm-=) ('< 's64-imm-<))))
- (with-cps cps
- (let$ body (specialize-comparison/immediate-s64-integer
- kf kt src imm-op b a
- (lambda (cps b)
- (with-cps cps
- (build-exp ($primcall op #f (a b)))))))
- (setk label ($kargs names vars ,body))))))
- (else
- (with-cps cps
- (let$ body (specialize-comparison/integer-s64
- kf kt src op a b
- (unbox-s64 b) (rebox-s64 b)))
- (setk label ($kargs names vars ,body))))))
- (else cps)))
- (else cps))
- types
- sigbits))
+ ($ $continue k src ($ $primcall op param args)))
+ (call-with-values
+ (lambda () (specialize-primcall cps k src op param args))
+ (lambda (cps term)
+ (values (if term
+ (with-cps cps
+ (setk label ($kargs names vars ,term)))
+ cps)
+ types sigbits))))
+
+ (($ $kargs names vars
+ ($ $continue kf src ($ $branch kt ($ $primcall op param args))))
+ (call-with-values
+ (lambda () (specialize-branch cps kf kt src op param args))
+ (lambda (cps term)
+ (values (if term
+ (with-cps cps
+ (setk label ($kargs names vars ,term)))
+ cps)
+ types sigbits))))
+
(_ (values cps types sigbits))))
(values (intmap-fold visit-cont cps cps #f #f)))