diff options
Diffstat (limited to 'module/language/cps/specialize-numbers.scm')
-rw-r--r-- | module/language/cps/specialize-numbers.scm | 1001 |
1 files changed, 1001 insertions, 0 deletions
diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm new file mode 100644 index 000000000..3bc929514 --- /dev/null +++ b/module/language/cps/specialize-numbers.scm @@ -0,0 +1,1001 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2015, 2016, 2017, 2018 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Some arithmetic operations have multiple implementations: one +;;; polymorphic implementation that works on all kinds of numbers, like +;;; `add', and one or more specialized variants for unboxed numbers of +;;; some kind, like `fadd'. If we can replace a polymorphic +;;; implementation with a monomorphic implementation, we should do so -- +;;; it will speed up the runtime and avoid boxing numbers. +;;; +;;; A polymorphic operation can be specialized if its result is +;;; specialized. To specialize an operation, we manually unbox its +;;; arguments and box its return value, relying on CSE to remove boxes +;;; where possible. +;;; +;;; We also want to specialize phi variables. A phi variable is bound +;;; by a continuation with more than one predecessor. For example in +;;; this code: +;;; +;;; (+ 1.0 (if a 2.0 3.0)) +;;; +;;; We want to specialize this code to: +;;; +;;; (f64->scm (fl+ (scm->f64 1.0) (if a (scm->f64 2.0) (scm->f64 3.0)))) +;;; +;;; Hopefully later passes will remove the conversions. In any case, +;;; specialization will likely result in a lower heap-number allocation +;;; rate, and that cost is higher than the extra opcodes to do +;;; conversions. This transformation is especially important for loop +;;; variables. +;;; +;;; Code: + +(define-module (language cps specialize-numbers) + #: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) + #:use-module (language cps renumber) + #:use-module (language cps types) + #:use-module (language cps utils) + #:use-module (language cps with-cps) + #:export (specialize-numbers)) + +;; A note on how to represent unboxing and boxing operations. We want +;; to avoid diamond control flows here, like: +;; +;; s64 x = (if (fixnum? x*) (untag-fixnum x*) (untag-bignum x*)) +;; +;; The reason is that the strategy that this specialize-numbers pass +;; uses to unbox values is to reify unboxing and boxing conversions +;; around every newly reified unboxed operation; it then relies heavily +;; on DCE and CSE to remove redundant conversions. However DCE and CSE +;; really work best when there's a linear control flow, so instead we +;; use a mid-level primcall: +;; +;; (define (scm->s64 x*) +;; (if (fixnum? x*) (untag-fixnum x*) (untag-bignum x*))) +;; +;; Then, unless we know that we can reduce directly to `untag-fixnum`, +;; we do: +;; +;; s64 x = (scm->s64 x*) +;; +;; That way we keep DCE and CSE happy. We can inline scm->s64 at the +;; backend if we choose to (though we might choose to not do so, for +;; code size reasons). + +(define (simple-primcall cps k src op arg) + (with-cps cps + (build-term + ($continue k src + ($primcall op #f (arg)))))) + +(define-syntax-rule (define-simple-primcall name) + (define (name cps k src arg) (simple-primcall cps k src 'name arg))) + +(define-simple-primcall untag-fixnum) +(define-simple-primcall scm->s64) +(define-simple-primcall tag-fixnum) +(define-simple-primcall s64->scm) +(define-simple-primcall tag-fixnum/unlikely) +(define-simple-primcall s64->scm/unlikely) + +(define (fixnum->u64 cps k src fx) + (with-cps cps + (letv s64) + (letk kcvt ($kargs ('s64) (s64) + ($continue k src ($primcall 's64->u64 #f (s64))))) + ($ (untag-fixnum kcvt src fx)))) +(define (u64->fixnum cps k src u64) + (with-cps cps + (letv s64) + (let$ tag-body (tag-fixnum k src s64)) + (letk ks64 ($kargs ('s64) (s64) ,tag-body)) + (build-term + ($continue ks64 src ($primcall 'u64->s64 #f (u64)))))) +(define-simple-primcall scm->u64) +(define-simple-primcall u64->scm) +(define-simple-primcall u64->scm/unlikely) + +(define-simple-primcall scm->f64) +(define-simple-primcall f64->scm) + +(define (specialize-unop cps k src op param a unbox-a box-result) + (with-cps cps + (letv a* result) + (let$ box-result-body (box-result k src result)) + (letk kbox ($kargs ('result) (result) ,box-result-body)) + (letk kop ($kargs ('a) (a*) + ($continue kbox src ($primcall op param (a*))))) + ($ (unbox-a kop src a)))) + +(define* (specialize-binop cps k src op a b + unbox-a unbox-b box-result) + (with-cps cps + (letv a* b* result) + (let$ box-result-body (box-result k src result)) + (letk kbox ($kargs ('result) (result) ,box-result-body)) + (letk kop ($kargs ('b) (b*) + ($continue kbox src ($primcall op #f (a* b*))))) + (let$ unbox-b-body (unbox-b kop src b)) + (letk kunbox-b ($kargs ('a) (a*) ,unbox-b-body)) + ($ (unbox-a kunbox-b src a)))) + +(define (specialize-comparison cps kf kt src op a b unbox-a unbox-b) + (with-cps cps + (letv a* b*) + (letk kop ($kargs ('b) (b*) ($branch kf kt src op #f (a* b*)))) + (let$ unbox-b-body (unbox-b kop src b)) + (letk kunbox-b ($kargs ('a) (a*) ,unbox-b-body)) + ($ (unbox-a kunbox-b src a)))) + +(define* (specialize-comparison/immediate cps kf kt src op a imm + unbox-a) + (with-cps cps + (letv ia) + (letk kop ($kargs ('ia) (ia) ($branch kf kt src op imm (ia)))) + ($ (unbox-a kop src a)))) + +(define (specialize-comparison/s64-integer cps kf kt src op a-s64 b-int + unbox-a rebox-a) + (let ((s64-op (match op ('= 's64-=) ('< 's64-<)))) + (with-cps cps + (letv a b sunk) + (letk kheap ($kargs ('sunk) (sunk) + ($branch kf kt src op #f (sunk b-int)))) + ;; Re-box the variable. FIXME: currently we use a specially + ;; marked s64->scm to avoid CSE from hoisting the allocation + ;; again. Instead we should just use a-s64 directly and implement + ;; an allocation sinking pass that should handle this.. + (let$ rebox-a-body (rebox-a kheap src a)) + (letk kretag ($kargs () () ,rebox-a-body)) + (letk kb ($kargs ('b) (b) ($branch kf kt src s64-op #f (a b)))) + (letk kfix ($kargs () () + ($continue kb src + ($primcall 'untag-fixnum #f (b-int))))) + (letk ka ($kargs ('a) (a) + ($branch kretag kfix src 'fixnum? #f (b-int)))) + ($ (unbox-a ka src a-s64))))) + +(define (specialize-comparison/integer-s64 cps kf kt src op a-int b-s64 + unbox-b rebox-b) + (match op + ('= (specialize-comparison/s64-integer cps kf kt src op b-s64 a-int + unbox-b rebox-b)) + ('< + (with-cps cps + (letv a b sunk) + (letk kheap ($kargs ('sunk) (sunk) + ($branch kf kt src '< #f (a-int sunk)))) + ;; FIXME: We should just use b-s64 directly and implement an + ;; allocation sinking pass so that the box op that creates b-64 + ;; should float down here. Instead, for now we just rebox the + ;; variable, relying on the reboxing op not being available for + ;; CSE. + (let$ rebox-b-body (rebox-b kheap src b)) + (letk kretag ($kargs () () ,rebox-b-body)) + (letk ka ($kargs ('a) (a) ($branch kf kt src 's64-< #f (a b)))) + (letk kfix ($kargs () () + ($continue ka src + ($primcall 'untag-fixnum #f (a-int))))) + (letk kb ($kargs ('b) (b) + ($branch kretag kfix src 'fixnum? #f (a-int)))) + ($ (unbox-b kb src b-s64)))))) + +(define (specialize-comparison/immediate-s64-integer cps kf kt src op a b-int + compare-integers) + (with-cps cps + (letv b sunk) + (letk kheap ($kargs ('sunk) (sunk) ,(compare-integers kf kt src sunk))) + ;; Re-box the variable. FIXME: currently we use a specially marked + ;; load-const to avoid CSE from hoisting the constant. Instead we + ;; should just use a $const directly and implement an allocation + ;; sinking pass that should handle this.. + (letk kretag ($kargs () () + ($continue kheap src + ($primcall 'load-const/unlikely a ())))) + (letk kb ($kargs ('b) (b) + ($branch kf kt src op a (b)))) + (letk kfix ($kargs () () + ($continue kb src + ($primcall 'untag-fixnum #f (b-int))))) + (build-term ($branch kretag kfix src 'fixnum? #f (b-int))))) + +(define (sigbits-union x y) + (and x y (logior x y))) + +(define (sigbits-intersect x y) + (cond + ((not x) y) + ((not y) x) + (else (logand x y)))) + +(define (sigbits-intersect3 a b c) + (sigbits-intersect a (sigbits-intersect b c))) + +(define (next-power-of-two n) + (let lp ((out 1)) + (if (< n out) + out + (lp (ash out 1))))) + +(define (range->sigbits min max) + (cond + ((or (< min 0) (> max #xffffFFFFffffFFFF)) #f) + ((eqv? min max) min) + (else (1- (next-power-of-two max))))) + +(define (inferred-sigbits types label var) + (call-with-values (lambda () (lookup-pre-type types label var)) + (lambda (type min max) + (and (type<=? type (logior &exact-integer &u64 &s64)) + (range->sigbits min max))))) + +(define significant-bits-handlers (make-hash-table)) +(define-syntax-rule (define-significant-bits-handler + ((primop label types out def ...) arg ...) + body ...) + (hashq-set! significant-bits-handlers 'primop + (lambda (label types out param args defs) + (match args ((arg ...) (match defs ((def ...) body ...))))))) + +(define-significant-bits-handler ((logand label types out res) a b) + (let ((sigbits (sigbits-intersect3 (inferred-sigbits types label a) + (inferred-sigbits types label b) + (intmap-ref out res (lambda (_) 0))))) + (intmap-add (intmap-add out a sigbits sigbits-union) + b sigbits sigbits-union))) + +(define (significant-bits-handler primop) + (hashq-ref significant-bits-handlers primop)) + +(define (compute-significant-bits cps types kfun) + "Given the locally inferred types @var{types}, compute a map of VAR -> +BITS indicating the significant bits needed for a variable. BITS may be +#f to indicate all bits, or a non-negative integer indicating a bitmask." + (let ((preds (invert-graph (compute-successors cps kfun)))) + (let lp ((worklist (intmap-keys preds)) (visited empty-intset) + (out empty-intmap)) + (match (intset-prev worklist) + (#f out) + (label + (let ((worklist (intset-remove worklist label)) + (visited* (intset-add visited label))) + (define (continue out*) + (if (and (eq? out out*) (eq? visited visited*)) + (lp worklist visited out) + (lp (intset-union worklist (intmap-ref preds label)) + visited* out*))) + (define (add-def out var) + (intmap-add out var 0 sigbits-union)) + (define (add-defs out vars) + (match vars + (() out) + ((var . vars) (add-defs (add-def out var) vars)))) + (define (add-unknown-use out var) + (intmap-add out var (inferred-sigbits types label var) + sigbits-union)) + (define (add-unknown-uses out vars) + (match vars + (() out) + ((var . vars) + (add-unknown-uses (add-unknown-use out var) vars)))) + (continue + (match (intmap-ref cps label) + (($ $kfun src meta self) + (add-def out self)) + (($ $kargs names vars term) + (let ((out (add-defs out vars))) + (match term + (($ $continue k src exp) + (match exp + ((or ($ $const) ($ $prim) ($ $fun) ($ $const-fun) + ($ $code) ($ $rec)) + ;; No uses, so no info added to sigbits. + out) + (($ $values args) + (match (intmap-ref cps k) + (($ $kargs _ vars) + (if (intset-ref visited k) + (fold (lambda (arg var out) + (intmap-add out arg (intmap-ref out var) + sigbits-union)) + out args vars) + out)) + (($ $ktail) + (add-unknown-uses out args)))) + (($ $call proc args) + (add-unknown-use (add-unknown-uses out args) proc)) + (($ $callk label proc args) + (add-unknown-use (add-unknown-uses out args) proc)) + (($ $primcall name param args) + (let ((h (significant-bits-handler name))) + (if h + (match (intmap-ref cps k) + (($ $kargs _ defs) + (h label types out param args defs))) + (add-unknown-uses out args)))))) + (($ $branch kf kt src op param args) + (add-unknown-uses out args)) + (($ $prompt k kh src escape? tag) + (add-unknown-use out tag)) + (($ $throw src op param args) + (add-unknown-uses out args))))) + (_ 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 () + (lookup-pre-type types label var)) + (lambda (type min max) + (and (type<=? type &type) (<= &min min max &max))))) + (define (u64-operand? var) + (operand-in-range? var &exact-integer 0 (1- (ash 1 64)))) + (define (u6-operand? var) + ;; This predicate is only used for the "count" argument to + ;; rsh/lsh, which is already unboxed to &u64. + (operand-in-range? var &u64 0 63)) + (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 + (target-most-negative-fixnum) + (target-most-positive-fixnum))) + (define (exact-integer-operand? var) + (operand-in-range? var &exact-integer -inf.0 +inf.0)) + (define (all-u64-bits-set? var) + (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 (1- (ash 1 64))))))) + (define (u64-result? result) + (or (only-u64-bits-used? result) + (call-with-values + (lambda () + (lookup-post-type types label result 0)) + (lambda (type min max) + (and (type<=? type &exact-integer) + (<= 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 (type<=? (logior typea typeb) &real) + (or (eqv? typea &flonum) + (eqv? typeb &flonum))))) + (define (constant-arg arg) + (let-values (((type min max) (lookup-pre-type types label arg))) + (and (= min max) min))) + (define (fixnum-range? min max) + (<= (target-most-negative-fixnum) min max (target-most-positive-fixnum))) + (define (unbox-u64 arg) + (if (fixnum-operand? arg) fixnum->u64 scm->u64)) + (define (unbox-s64 arg) + (if (fixnum-operand? arg) untag-fixnum scm->s64)) + (define (rebox-s64 arg) + (if (fixnum-operand? arg) tag-fixnum/unlikely s64->scm/unlikely)) + (define (unbox-f64 arg) + ;; Could be more precise here. + scm->f64) + (define (box-s64 result) + (if (fixnum-result? result) tag-fixnum s64->scm)) + (define (box-u64 result) + (if (fixnum-result? result) u64->fixnum u64->scm)) + (define (box-f64 result) + f64->scm) + + (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 + (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 + (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) + (('<= a b) + (cond + ((f64-operands? a b) + (specialize-comparison cps kf kt src 'f64-<= a b + (unbox-f64 a) (unbox-f64 b))) + ((and (exact-integer-operand? a) (exact-integer-operand? b)) + ;; If NaN is impossible, reduce (<= a b) to (not (< b a)) and + ;; try again. + (specialize-branch cps kt kf src '< param (list b a))) + (else + (with-cps cps #f)))) + (((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 (kf kt src a) + (build-term ($branch kf kt src 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 (kf kt src b) + (build-term ($branch kf kt src 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)))) + + (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 + (setk label ($kargs names vars ,term))) + cps) + types sigbits)))) + + (($ $kargs names vars ($ $branch kf kt src 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))) + +;; Compute a map from VAR -> LABEL, where LABEL indicates the cont that +;; binds VAR. +(define (compute-defs conts labels) + (intset-fold + (lambda (label defs) + (match (intmap-ref conts label) + (($ $kfun src meta self tail clause) + (intmap-add defs self label)) + (($ $kargs names vars) + (fold1 (lambda (var defs) + (intmap-add defs var label)) + vars defs)) + (_ defs))) + labels empty-intmap)) + +;; Compute vars whose definitions are all unboxable and whose uses +;; include an unbox operation. +(define (compute-specializable-vars cps body preds defs + exp-result-unboxable? + unbox-ops) + ;; Compute a map of VAR->LABEL... indicating the set of labels that + ;; define VAR with unboxable values, given the set of vars + ;; UNBOXABLE-VARS which is known already to be unboxable. + (define (collect-unboxable-def-labels unboxable-vars) + (define (add-unboxable-def unboxable-defs var label) + (intmap-add unboxable-defs var (intset label) intset-union)) + (intset-fold (lambda (label unboxable-defs) + (match (intmap-ref cps label) + (($ $kargs _ _ ($ $continue k _ exp)) + (match exp + ((? exp-result-unboxable?) + (match (intmap-ref cps k) + (($ $kargs (_) (def)) + (add-unboxable-def unboxable-defs def label)))) + (($ $values vars) + (match (intmap-ref cps k) + (($ $kargs _ defs) + (fold + (lambda (var def unboxable-defs) + (if (intset-ref unboxable-vars var) + (add-unboxable-def unboxable-defs def label) + unboxable-defs)) + unboxable-defs vars defs)) + ;; Could be $ktail for $values. + (_ unboxable-defs))) + (_ unboxable-defs))) + (_ unboxable-defs))) + body empty-intmap)) + + ;; Compute the set of vars which are always unboxable. + (define (compute-unboxable-defs) + (fixpoint + (lambda (unboxable-vars) + (intmap-fold + (lambda (def unboxable-pred-labels unboxable-vars) + (if (and (not (intset-ref unboxable-vars def)) + ;; Are all defining expressions unboxable? + (and-map (lambda (pred) + (intset-ref unboxable-pred-labels pred)) + (intmap-ref preds (intmap-ref defs def)))) + (intset-add unboxable-vars def) + unboxable-vars)) + (collect-unboxable-def-labels unboxable-vars) + unboxable-vars)) + empty-intset)) + + ;; Compute the set of vars that may ever be unboxed. + (define (compute-unbox-uses unboxable-defs) + (intset-fold + (lambda (label unbox-uses) + (match (intmap-ref cps label) + (($ $kargs _ _ ($ $continue k _ exp)) + (match exp + (($ $primcall (? (lambda (op) (memq op unbox-ops))) #f (var)) + (intset-add unbox-uses var)) + (($ $values vars) + (match (intmap-ref cps k) + (($ $kargs _ defs) + (fold (lambda (var def unbox-uses) + (if (intset-ref unboxable-defs def) + (intset-add unbox-uses var) + unbox-uses)) + unbox-uses vars defs)) + (($ $ktail) + ;; Assume return is rare and that any unboxable def can + ;; be reboxed when leaving the procedure. + (fold (lambda (var unbox-uses) + (intset-add unbox-uses var)) + unbox-uses vars)))) + (_ unbox-uses))) + (_ unbox-uses))) + body empty-intset)) + + (let ((unboxable-defs (compute-unboxable-defs))) + (intset-intersect unboxable-defs (compute-unbox-uses unboxable-defs)))) + +;; Compute vars whose definitions are all inexact reals and whose uses +;; include an unbox operation. +(define (compute-specializable-f64-vars cps body preds defs) + ;; Can the result of EXP definitely be unboxed as an f64? + (define (exp-result-f64? exp) + (match exp + ((or ($ $primcall 'f64->scm #f (_)) + ($ $const (and (? number?) (? inexact?) (? real?)))) + #t) + (_ #f))) + (compute-specializable-vars cps body preds defs exp-result-f64? '(scm->f64))) + +;; Compute vars whose definitions are all exact integers in the u64 +;; range and whose uses include an unbox operation. +(define (compute-specializable-u64-vars cps body preds defs) + ;; Can the result of EXP definitely be unboxed as a u64? + (define (exp-result-u64? exp) + (define (u64? n) + (and (number? n) (exact-integer? n) + (<= 0 n #xffffffffffffffff))) + (match exp + ((or ($ $primcall 'u64->scm #f (_)) + ($ $primcall 'u64->scm/unlikely #f (_)) + ($ $primcall 'load-const/unlikely (? u64?) ()) + ($ $const (? u64?))) + #t) + (_ #f))) + + (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) + (define (fixnum? n) + (and (number? n) (exact-integer? n) + (<= (target-most-negative-fixnum) + n + (target-most-positive-fixnum)))) + (match exp + ((or ($ $primcall 'tag-fixnum #f (_)) + ($ $primcall 'tag-fixnum/unlikely #f (_)) + ($ $const (? fixnum?)) + ($ $primcall 'load-const/unlikely (? fixnum?) ())) + #t) + (_ #f))) + + (compute-specializable-vars cps body preds defs exp-result-fixnum? + '(untag-fixnum))) + +;; Compute vars whose definitions are all exact integers in the s64 +;; range and whose uses include an untag operation. +(define (compute-specializable-s64-vars cps body preds defs) + ;; Is the result of EXP definitely a fixnum? + (define (exp-result-fixnum? exp) + (define (s64? n) + (and (number? n) (exact-integer? n) + (<= (ash -1 63) n (1- (ash 1 63))))) + (match exp + ((or ($ $primcall 's64->scm #f (_)) + ($ $const (? s64?)) + ($ $primcall 'load-const/unlikely (? s64?) ())) + #t) + (_ #f))) + + (compute-specializable-vars cps body preds defs exp-result-fixnum? + '(scm->s64))) + +(define (compute-phi-vars cps preds) + (intmap-fold (lambda (label preds phis) + (match preds + (() phis) + ((_) phis) + (_ + (match (intmap-ref cps label) + (($ $kargs names vars) + (fold1 (lambda (var phis) + (intset-add phis var)) + vars phis)) + (_ phis))))) + preds empty-intset)) + +;; Compute the set of variables which have more than one definition, +;; whose definitions are always f64-valued or u64-valued, and which have +;; at least one use that is an unbox operation. +(define (compute-specializable-phis cps body preds defs) + (let ((phi-vars (compute-phi-vars cps preds))) + (fold1 (lambda (in out) + (match in + ((kind vars) + (intset-fold + (lambda (var out) + (intmap-add out var kind (lambda (old new) old))) + (intset-intersect phi-vars vars) + out)))) + `((f64 ,(compute-specializable-f64-vars cps body preds defs)) + (fx ,(compute-specializable-fixnum-vars cps body preds defs)) + (s64 ,(compute-specializable-s64-vars cps body preds defs)) + (u64 ,(compute-specializable-u64-vars cps body preds defs))) + empty-intmap))) + +;; Each definition of a f64/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) + (define (compute-unbox-labels) + (intmap-fold (lambda (phi kind labels) + (fold1 (lambda (pred labels) + (intset-add labels pred)) + (intmap-ref preds (intmap-ref defs phi)) + labels)) + phis empty-intset)) + (define (unbox-op var) + (match (intmap-ref phis var) + ('f64 'scm->f64) + ('fx 'untag-fixnum) + ('s64 'scm->s64) + ('u64 'scm->u64))) + (define (box-op var) + (match (intmap-ref phis var) + ('f64 'f64->scm) + ('fx 'tag-fixnum) + ('s64 's64->scm) + ('u64 'u64->scm))) + (define (unbox-operands) + (define (unbox-arg cps arg def-var have-arg) + (if (intmap-ref phis def-var (lambda (_) #f)) + (with-cps cps + (letv unboxed) + (let$ body (have-arg unboxed)) + (letk kunboxed ($kargs ('unboxed) (unboxed) ,body)) + (build-term + ($continue kunboxed #f ($primcall (unbox-op def-var) #f (arg))))) + (have-arg cps arg))) + (define (unbox-args cps args def-vars have-args) + (match args + (() (have-args cps '())) + ((arg . args) + (match def-vars + ((def-var . def-vars) + (unbox-arg cps arg def-var + (lambda (cps arg) + (unbox-args cps args def-vars + (lambda (cps args) + (have-args cps (cons arg args))))))))))) + (intset-fold + (lambda (label cps) + (match (intmap-ref cps label) + (($ $kargs names vars ($ $continue k src exp)) + (match (intmap-ref cps k) + (($ $kargs _ defs) + (match exp + ;; For expressions that define a single value, we know we need + ;; to unbox that value. For $values though we might have to + ;; unbox just a subset of values. + (($ $values args) + (with-cps cps + (let$ term (unbox-args + args defs + (lambda (cps args) + (with-cps cps + (build-term + ($continue k src ($values args))))))) + (setk label ($kargs names vars ,term)))) + (_ + (match defs + ((def) + (with-cps cps + (letv boxed) + (letk kunbox ($kargs ('boxed) (boxed) + ($continue k src + ($primcall (unbox-op def) #f (boxed))))) + (setk label ($kargs names vars + ($continue kunbox src ,exp))))))))))))) + (compute-unbox-labels) + cps)) + (define (compute-box-labels) + (intmap-fold (lambda (phi kind labels) + (intset-add labels (intmap-ref defs phi))) + phis empty-intset)) + (define (box-results cps) + (intset-fold + (lambda (label cps) + (match (intmap-ref cps label) + (($ $kargs names vars term) + (let* ((boxed (fold1 (lambda (var boxed) + (if (intmap-ref phis var (lambda (_) #f)) + (intmap-add boxed var (fresh-var)) + boxed)) + vars empty-intmap)) + (bound-vars (map (lambda (var) + (intmap-ref boxed var (lambda (var) var))) + vars))) + (define (box-var cps name var done) + (let ((unboxed (intmap-ref boxed var (lambda (_) #f)))) + (if unboxed + (with-cps cps + (let$ term (done)) + (letk kboxed ($kargs (name) (var) ,term)) + (build-term + ($continue kboxed #f + ($primcall (box-op var) #f (unboxed))))) + (done cps)))) + (define (box-vars cps names vars done) + (match vars + (() (done cps)) + ((var . vars) + (match names + ((name . names) + (box-var cps name var + (lambda (cps) + (box-vars cps names vars done)))))))) + (with-cps cps + (let$ box-term (box-vars names vars + (lambda (cps) + (with-cps cps term)))) + (setk label ($kargs names bound-vars ,box-term))))))) + (compute-box-labels) + cps)) + (box-results (unbox-operands))) + +(define (specialize-phis cps) + (intmap-fold + (lambda (kfun body cps) + (let* ((preds (compute-predecessors cps kfun #:labels body)) + (defs (compute-defs cps body)) + (phis (compute-specializable-phis cps body preds defs))) + (if (eq? phis empty-intmap) + cps + (apply-specialization cps kfun body preds defs phis)))) + (compute-reachable-functions cps) + cps)) + +(define (specialize-numbers cps) + ;; Type inference wants a renumbered graph; OK. + (let ((cps (renumber cps))) + (with-fresh-name-state cps + (specialize-phis (specialize-operations cps))))) |