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

Refactor number specialization to reduce duplication

Browse source 
* module/language/cps/specialize-numbers.scm (specialize-operations):
  Factor out specialize-primcall and specialize-branch operations.
This commit is contained in:
Andy Wingo 2017-12-02 11:43:44 +01:00
parent bcfadf099a
commit 8c37cf083f
1 changed files with 210 additions and 256 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -451,13 +451,7 @@ BITS indicating the significant bits needed for a variable. BITS may be
(define (box-f64 result) (define (box-f64 result)
f64->scm) f64->scm)
(match cont (define (specialize-primcall cps k src op param args)
(($ $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) (match (intmap-ref cps k)
(($ $kargs (_) (result)) (($ $kargs (_) (result))
(match (cons* op result param args) (match (cons* op result param args)
@ -465,12 +459,8 @@ BITS indicating the significant bits needed for a variable. BITS may be
(? f64-result?) #f a b) (? f64-result?) #f a b)
(let ((op (match op (let ((op (match op
('add 'fadd) ('sub 'fsub) ('mul 'fmul) ('div 'fdiv)))) ('add 'fadd) ('sub 'fsub) ('mul 'fmul) ('div 'fdiv))))
(with-cps cps (specialize-binop cps k src op a b
(let$ body (specialize-binop (unbox-f64 a) (unbox-f64 b) (box-f64 result))))
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) (((or 'add 'sub 'mul 'logand 'logior 'logxor 'logsub)
(? u64-result?) #f (? u64-operand? a) (? u64-operand? b)) (? u64-result?) #f (? u64-operand? a) (? u64-operand? b))
@ -478,11 +468,8 @@ BITS indicating the significant bits needed for a variable. BITS may be
('add 'uadd) ('sub 'usub) ('mul 'umul) ('add 'uadd) ('sub 'usub) ('mul 'umul)
('logand 'ulogand) ('logior 'ulogior) ('logand 'ulogand) ('logior 'ulogior)
('logxor 'ulogxor) ('logsub 'ulogsub)))) ('logxor 'ulogxor) ('logsub 'ulogsub))))
(with-cps cps (specialize-binop cps k src op a b
(let$ body (specialize-binop (unbox-u64 a) (unbox-u64 b) (box-u64 result))))
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) (((or 'logand 'logior 'logxor 'logsub)
(? u64-result?) #f (? s64-operand? a) (? s64-operand? b)) (? u64-result?) #f (? s64-operand? a) (? s64-operand? b))
@ -498,40 +485,28 @@ BITS indicating the significant bits needed for a variable. BITS may be
($continue k src ($continue k src
($primcall 's64->u64 #f (s64))))) ($primcall 's64->u64 #f (s64)))))
($ (unbox-s64 k src x)))))) ($ (unbox-s64 k src x))))))
(with-cps cps (specialize-binop cps k src op a b
(let$ body (specialize-binop (unbox-u64* a) (unbox-u64* b) (box-u64 result))))
k src op a b
(unbox-u64* a) (unbox-u64* b) (box-u64 result)))
(setk label ($kargs names vars ,body)))))
(((or 'add 'sub 'mul) (((or 'add 'sub 'mul)
(? s64-result?) #f (? s64-operand? a) (? s64-operand? b)) (? s64-result?) #f (? s64-operand? a) (? s64-operand? b))
(let ((op (match op (let ((op (match op
('add 'sadd) ('sub 'ssub) ('mul 'smul)))) ('add 'sadd) ('sub 'ssub) ('mul 'smul))))
(with-cps cps (specialize-binop cps k src op a b
(let$ body (specialize-binop (unbox-s64 a) (unbox-s64 b) (box-s64 result))))
k src op a b
(unbox-s64 a) (unbox-s64 b) (box-s64 result)))
(setk label ($kargs names vars ,body)))))
(('sub/immediate (('sub/immediate
(? f64-result?) param a) (? f64-result?) param a)
(with-cps cps (specialize-unop cps k src 'fadd/immediate (- param) a
(let$ body (specialize-unop
k src 'fadd/immediate (- param) a
(unbox-f64 a) (box-f64 result))) (unbox-f64 a) (box-f64 result)))
(setk label ($kargs names vars ,body))))
(((or 'add/immediate 'mul/immediate) (((or 'add/immediate 'mul/immediate)
(? f64-result?) param a) (? f64-result?) param a)
(let ((op (match op (let ((op (match op
('add/immediate 'fadd/immediate) ('add/immediate 'fadd/immediate)
('mul/immediate 'fmul/immediate)))) ('mul/immediate 'fmul/immediate))))
(with-cps cps (specialize-unop cps k src op param a
(let$ body (specialize-unop (unbox-f64 a) (box-f64 result))))
k src op param a
(unbox-f64 a) (box-f64 result)))
(setk label ($kargs names vars ,body)))))
(((or 'add/immediate 'sub/immediate 'mul/immediate) (((or 'add/immediate 'sub/immediate 'mul/immediate)
(? u64-result?) (? u64-parameter?) (? u64-operand? a)) (? u64-result?) (? u64-parameter?) (? u64-operand? a))
@ -539,11 +514,8 @@ BITS indicating the significant bits needed for a variable. BITS may be
('add/immediate 'uadd/immediate) ('add/immediate 'uadd/immediate)
('sub/immediate 'usub/immediate) ('sub/immediate 'usub/immediate)
('mul/immediate 'umul/immediate)))) ('mul/immediate 'umul/immediate))))
(with-cps cps (specialize-unop cps k src op param a
(let$ body (specialize-unop (unbox-u64 a) (box-u64 result))))
k src op param a
(unbox-u64 a) (box-u64 result)))
(setk label ($kargs names vars ,body)))))
(((or 'add/immediate 'sub/immediate 'mul/immediate) (((or 'add/immediate 'sub/immediate 'mul/immediate)
(? s64-result?) (? s64-parameter?) (? s64-operand? a)) (? s64-result?) (? s64-parameter?) (? s64-operand? a))
@ -551,11 +523,8 @@ BITS indicating the significant bits needed for a variable. BITS may be
('add/immediate 'sadd/immediate) ('add/immediate 'sadd/immediate)
('sub/immediate 'ssub/immediate) ('sub/immediate 'ssub/immediate)
('mul/immediate 'smul/immediate)))) ('mul/immediate 'smul/immediate))))
(with-cps cps (specialize-unop cps k src op param a
(let$ body (specialize-unop (unbox-s64 a) (box-s64 result))))
k src op param a
(unbox-s64 a) (box-s64 result)))
(setk label ($kargs names vars ,body)))))
(((or 'lsh 'rsh) (((or 'lsh 'rsh)
(? u64-result?) #f (? u64-operand? a) (? u6-operand? b)) (? u64-result?) #f (? u64-operand? a) (? u6-operand? b))
@ -563,11 +532,8 @@ BITS indicating the significant bits needed for a variable. BITS may be
(define (pass-u64 cps k src b) (define (pass-u64 cps k src b)
(with-cps cps (with-cps cps
(build-term ($continue k src ($values (b)))))) (build-term ($continue k src ($values (b))))))
(with-cps cps (specialize-binop cps k src op a b
(let$ body (specialize-binop (unbox-u64 a) pass-u64 (box-u64 result))))
k src op a b
(unbox-u64 a) pass-u64 (box-u64 result)))
(setk label ($kargs names vars ,body)))))
(((or 'lsh 'rsh) (((or 'lsh 'rsh)
(? s64-result?) #f (? s64-operand? a) (? u6-operand? b)) (? s64-result?) #f (? s64-operand? a) (? u6-operand? b))
@ -575,100 +541,68 @@ BITS indicating the significant bits needed for a variable. BITS may be
(define (pass-u64 cps k src b) (define (pass-u64 cps k src b)
(with-cps cps (with-cps cps
(build-term ($continue k src ($values (b)))))) (build-term ($continue k src ($values (b))))))
(with-cps cps (specialize-binop cps k src op a b
(let$ body (specialize-binop (unbox-s64 a) pass-u64 (box-s64 result))))
k src op a b
(unbox-s64 a) pass-u64 (box-s64 result)))
(setk label ($kargs names vars ,body)))))
(((or 'lsh/immediate 'rsh/immediate) (((or 'lsh/immediate 'rsh/immediate)
(? u64-result?) (? u6-parameter?) (? u64-operand? a)) (? u64-result?) (? u6-parameter?) (? u64-operand? a))
(let ((op (match op (let ((op (match op
('lsh/immediate 'ulsh/immediate) ('lsh/immediate 'ulsh/immediate)
('rsh/immediate 'ursh/immediate)))) ('rsh/immediate 'ursh/immediate))))
(with-cps cps (specialize-unop cps k src op param a
(let$ body (specialize-unop (unbox-u64 a) (box-u64 result))))
k src op param a
(unbox-u64 a) (box-u64 result)))
(setk label ($kargs names vars ,body)))))
(((or 'lsh/immediate 'rsh/immediate) (((or 'lsh/immediate 'rsh/immediate)
(? s64-result?) (? u6-parameter?) (? s64-operand? a)) (? s64-result?) (? u6-parameter?) (? s64-operand? a))
(let ((op (match op (let ((op (match op
('lsh/immediate 'slsh/immediate) ('lsh/immediate 'slsh/immediate)
('rsh/immediate 'srsh/immediate)))) ('rsh/immediate 'srsh/immediate))))
(with-cps cps (specialize-unop cps k src op param a
(let$ body (specialize-unop (unbox-s64 a) (box-s64 result))))
k src op param a
(unbox-s64 a) (box-s64 result)))
(setk label ($kargs names vars ,body)))))
(_ cps))) (_ (with-cps cps #f))))
(_ cps)) (_ (with-cps cps #f))))
types
sigbits))
(($ $kargs names vars (define (specialize-branch cps kf kt src op param args)
($ $continue kf src (match (cons op args)
($ $branch kt ($ $primcall (and op (or '< '=)) #f (a b))))) (((or '< '=) a b)
(values
(cond (cond
((f64-operands? a b) ((f64-operands? a b)
(let ((op (match op ('= 'f64-=) ('< 'f64-<)))) (let ((op (match op ('= 'f64-=) ('< 'f64-<))))
(with-cps cps (specialize-comparison cps kf kt src op a b
(let$ body (specialize-comparison kf kt src op a b (unbox-f64 a) (unbox-f64 b))))
(unbox-f64 a) (unbox-f64 b)))
(setk label ($kargs names vars ,body)))))
((and (s64-operand? a) (s64-operand? b)) ((and (s64-operand? a) (s64-operand? b))
(cond (cond
((constant-arg a) ((constant-arg a)
=> (lambda (a) => (lambda (a)
(let ((op (match op ('= 's64-imm-=) ('< 'imm-s64-<)))) (let ((op (match op ('= 's64-imm-=) ('< 'imm-s64-<))))
(with-cps cps (specialize-comparison/immediate cps kf kt src op b a
(let$ body (specialize-comparison/immediate (unbox-s64 b)))))
kf kt src op b a
(unbox-s64 b)))
(setk label ($kargs names vars ,body))))))
((constant-arg b) ((constant-arg b)
=> (lambda (b) => (lambda (b)
(let ((op (match op ('= 's64-imm-=) ('< 's64-imm-<)))) (let ((op (match op ('= 's64-imm-=) ('< 's64-imm-<))))
(with-cps cps (specialize-comparison/immediate cps kf kt src op a b
(let$ body (specialize-comparison/immediate (unbox-s64 a)))))
kf kt src op a b
(unbox-s64 a)))
(setk label ($kargs names vars ,body))))))
(else (else
(let ((op (match op ('= 's64-=) ('< 's64-<)))) (let ((op (match op ('= 's64-=) ('< 's64-<))))
(with-cps cps (specialize-comparison cps kf kt src op a b
(let$ body (specialize-comparison (unbox-s64 a) (unbox-s64 b))))))
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)) ((and (u64-operand? a) (u64-operand? b))
(cond (cond
((constant-arg a) ((constant-arg a)
=> (lambda (a) => (lambda (a)
(let ((op (match op ('= 'u64-imm-=) ('< 'imm-u64-<)))) (let ((op (match op ('= 'u64-imm-=) ('< 'imm-u64-<))))
(with-cps cps (specialize-comparison/immediate cps kf kt src op b a
(let$ body (specialize-comparison/immediate (unbox-u64 b)))))
kf kt src op b a
(unbox-u64 b)))
(setk label ($kargs names vars ,body))))))
((constant-arg b) ((constant-arg b)
=> (lambda (b) => (lambda (b)
(let ((op (match op ('= 'u64-imm-=) ('< 'u64-imm-<)))) (let ((op (match op ('= 'u64-imm-=) ('< 'u64-imm-<))))
(with-cps cps (specialize-comparison/immediate cps kf kt src op a b
(let$ body (specialize-comparison/immediate (unbox-u64 a)))))
kf kt src op a b
(unbox-u64 a)))
(setk label ($kargs names vars ,body))))))
(else (else
(let ((op (match op ('= 'u64-=) ('< 'u64-<)))) (let ((op (match op ('= 'u64-=) ('< 'u64-<))))
(with-cps cps (specialize-comparison cps kf kt src op a b
(let$ body (specialize-comparison (unbox-u64 a) (unbox-u64 b))))))
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)) ((and (exact-integer-operand? a) (exact-integer-operand? b))
(cond (cond
((s64-operand? a) ((s64-operand? a)
@ -676,41 +610,61 @@ BITS indicating the significant bits needed for a variable. BITS may be
((constant-arg a) ((constant-arg a)
=> (lambda (a) => (lambda (a)
(let ((imm-op (match op ('= 's64-imm-=) ('< 'imm-s64-<)))) (let ((imm-op (match op ('= 's64-imm-=) ('< 'imm-s64-<))))
(with-cps cps (specialize-comparison/immediate-s64-integer
(let$ body (specialize-comparison/immediate-s64-integer cps kf kt src imm-op a b
kf kt src imm-op a b
(lambda (cps a) (lambda (cps a)
(with-cps cps (with-cps cps
(build-exp ($primcall op #f (a b))))))) (build-exp ($primcall op #f (a b)))))))))
(setk label ($kargs names vars ,body))))))
(else (else
(with-cps cps (specialize-comparison/s64-integer cps kf kt src op a b
(let$ body (specialize-comparison/s64-integer (unbox-s64 a)
kf kt src op a b (rebox-s64 a)))))
(unbox-s64 a) (rebox-s64 a)))
(setk label ($kargs names vars ,body))))))
((s64-operand? b) ((s64-operand? b)
(cond (cond
((constant-arg b) ((constant-arg b)
=> (lambda (b) => (lambda (b)
(let ((imm-op (match op ('= 's64-imm-=) ('< 's64-imm-<)))) (let ((imm-op (match op ('= 's64-imm-=) ('< 's64-imm-<))))
(with-cps cps (specialize-comparison/immediate-s64-integer
(let$ body (specialize-comparison/immediate-s64-integer cps kf kt src imm-op b a
kf kt src imm-op b a
(lambda (cps b) (lambda (cps b)
(with-cps cps (with-cps cps
(build-exp ($primcall op #f (a b))))))) (build-exp ($primcall op #f (a b)))))))))
(setk label ($kargs names vars ,body))))))
(else (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))))
(match cont
(($ $kfun)
(let* ((types (infer-types cps label))
(sigbits (compute-significant-bits cps types label)))
(values cps types sigbits)))
(($ $kargs names vars
($ $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 (with-cps cps
(let$ body (specialize-comparison/integer-s64 (setk label ($kargs names vars ,term)))
kf kt src op a b cps)
(unbox-s64 b) (rebox-s64 b))) types sigbits))))
(setk label ($kargs names vars ,body))))))
(else cps))) (($ $kargs names vars
(else cps)) ($ $continue kf src ($ $branch kt ($ $primcall op param args))))
types (call-with-values
sigbits)) (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 cps types sigbits))))
(values (intmap-fold visit-cont cps cps #f #f))) (values (intmap-fold visit-cont cps cps #f #f)))