Refactoring of the optimizer.
original commit: c3f46cc8a6512379ead3cf99cf94fe426bec3f5a
This commit is contained in:
Vincent St-Amour
parent
e9ff5ae34d
commit
8deff8c920
58
collects/typed-scheme/optimizer/fixnum.rkt
Normal file
58
collects/typed-scheme/optimizer/fixnum.rkt
Normal file
|
|
@ -0,0 +1,58 @@
|
|||
#lang scheme
|
||||
|
||||
(require syntax/parse
|
||||
"../utils/utils.rkt"
|
||||
(for-template scheme/base scheme/fixnum scheme/unsafe/ops)
|
||||
(types abbrev type-table utils subtype)
|
||||
(optimizer utils))
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define-syntax-class fixnum-opt-expr
|
||||
(pattern e:expr
|
||||
#:when (subtypeof? #'e -Fixnum)
|
||||
#:with opt ((optimize) #'e)))
|
||||
(define-syntax-class nonzero-fixnum-opt-expr
|
||||
(pattern e:expr
|
||||
#:when (or (isoftype? #'e -PositiveFixnum) (isoftype? #'e -NegativeFixnum))
|
||||
#:with opt ((optimize) #'e)))
|
||||
|
||||
(define (mk-fixnum-tbl generic)
|
||||
(mk-unsafe-tbl generic "fx~a" "unsafe-fx~a"))
|
||||
|
||||
;; due to undefined behavior when results are out of the fixnum range, only some
|
||||
;; fixnum operations can be optimized
|
||||
;; the following must be closed on fixnums
|
||||
(define binary-fixnum-ops
|
||||
(dict-set
|
||||
(dict-set
|
||||
(dict-set
|
||||
(dict-set
|
||||
(dict-set
|
||||
(dict-set
|
||||
(mk-fixnum-tbl (list #'= #'<= #'< #'> #'>= #'min #'max))
|
||||
#'bitwise-and #'unsafe-fxand)
|
||||
#'fxand #'unsafe-fxand)
|
||||
#'bitwise-ior #'unsafe-fxior)
|
||||
#'fxior #'unsafe-fxior)
|
||||
#'bitwise-xor #'unsafe-fxxor)
|
||||
#'fxxor #'unsafe-fxxor))
|
||||
(define-syntax-class fixnum-unary-op
|
||||
(pattern (~or (~literal bitwise-not) (~literal fxnot)) #:with unsafe #'unsafe-fxnot)
|
||||
(pattern (~or (~literal abs) (~literal fxabs)) #:with unsafe #'unsafe-fxabs))
|
||||
;; closed on fixnums, but 2nd argument must not be 0
|
||||
(define-syntax-class nonzero-fixnum-binary-op
|
||||
(pattern (~or (~literal quotient) (~literal fxquotient)) #:with unsafe #'unsafe-fxquotient)
|
||||
(pattern (~or (~literal modulo) (~literal fxmodulo)) #:with unsafe #'unsafe-fxmodulo)
|
||||
(pattern (~or (~literal remainder) (~literal fxremainder)) #:with unsafe #'unsafe-fxremainder))
|
||||
|
||||
(define-syntax-class (fixnum-op tbl)
|
||||
(pattern i:id
|
||||
#:when (dict-ref tbl #'i #f)
|
||||
#:with unsafe (dict-ref tbl #'i)))
|
||||
|
||||
|
||||
(define (optimize-finum-expr stx)
|
||||
(syntax-parse stx #:literal-sets (kernel-literals)
|
||||
[e:fixnum-opt-expr
|
||||
(syntax/loc stx e.opt)]))
|
||||
59
collects/typed-scheme/optimizer/float.rkt
Normal file
59
collects/typed-scheme/optimizer/float.rkt
Normal file
|
|
@ -0,0 +1,59 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require syntax/parse
|
||||
syntax/id-table racket/dict
|
||||
(for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops)
|
||||
"../utils/utils.rkt"
|
||||
(types abbrev type-table utils subtype)
|
||||
(optimizer utils fixnum))
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define-syntax-class float-opt-expr
|
||||
(pattern e:expr
|
||||
#:when (subtypeof? #'e -Flonum)
|
||||
#:with opt ((optimize) #'e)))
|
||||
(define-syntax-class int-opt-expr
|
||||
(pattern e:expr
|
||||
#:when (subtypeof? #'e -Integer)
|
||||
#:with opt ((optimize) #'e)))
|
||||
|
||||
;; if the result of an operation is of type float, its non float arguments
|
||||
;; can be promoted, and we can use unsafe float operations
|
||||
;; note: none of the unary operations have types where non-float arguments
|
||||
;; can result in float (as opposed to real) results
|
||||
(define-syntax-class float-arg-expr
|
||||
(pattern e:fixnum-opt-expr
|
||||
#:with opt #'(unsafe-fx->fl e.opt))
|
||||
(pattern e:int-opt-expr
|
||||
#:with opt #'(->fl e.opt))
|
||||
(pattern e:float-opt-expr
|
||||
#:with opt #'e.opt))
|
||||
|
||||
(define (mk-float-tbl generic)
|
||||
(mk-unsafe-tbl generic "fl~a" "unsafe-fl~a"))
|
||||
|
||||
(define binary-float-ops
|
||||
(mk-float-tbl (list #'+ #'- #'* #'/ #'min #'max)))
|
||||
(define binary-float-comps
|
||||
(dict-set
|
||||
(dict-set
|
||||
(mk-float-tbl (list #'= #'<= #'< #'> #'>=))
|
||||
;; not a comparison, but takes 2 floats and does not return a float,
|
||||
;; unlike binary-float-ops
|
||||
#'make-rectangular #'unsafe-make-flrectangular)
|
||||
#'make-flrectangular #'unsafe-make-flrectangular))
|
||||
(define unary-float-ops
|
||||
(mk-float-tbl (list #'abs #'sin #'cos #'tan #'asin #'acos #'atan #'log #'exp
|
||||
#'sqrt #'round #'floor #'ceiling #'truncate)))
|
||||
|
||||
(define-syntax-class (float-op tbl)
|
||||
(pattern i:id
|
||||
#:when (dict-ref tbl #'i #f)
|
||||
#:with unsafe (dict-ref tbl #'i)))
|
||||
|
||||
|
||||
(define (optimize-float-expr stx)
|
||||
(syntax-parse stx #:literal-sets (kernel-literals)
|
||||
[e:float-opt-expr
|
||||
(syntax/loc stx e.opt)]))
|
||||
134
collects/typed-scheme/optimizer/inexact-complex.rkt
Normal file
134
collects/typed-scheme/optimizer/inexact-complex.rkt
Normal file
|
|
@ -0,0 +1,134 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require syntax/parse
|
||||
"../utils/utils.rkt"
|
||||
(for-template scheme/base scheme/flonum scheme/unsafe/ops)
|
||||
(types abbrev type-table utils subtype)
|
||||
(optimizer utils float))
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
|
||||
(define-syntax-class inexact-complex-opt-expr
|
||||
(pattern e:expr
|
||||
#:when (isoftype? #'e -InexactComplex)
|
||||
#:with opt ((optimize) #'e)))
|
||||
|
||||
;; it's faster to take apart a complex number and use unsafe operations on
|
||||
;; its parts than it is to use generic operations
|
||||
;; we keep the real and imaginary parts unboxed as long as we stay within
|
||||
;; complex operations
|
||||
(define-syntax-class unboxed-inexact-complex-opt-expr
|
||||
(pattern (#%plain-app (~and (~var op (float-op binary-inexact-complex-ops)) (~or (~literal +) (~literal -)))
|
||||
c1:unboxed-inexact-complex-opt-expr
|
||||
c2:unboxed-inexact-complex-opt-expr
|
||||
cs:unboxed-inexact-complex-opt-expr ...)
|
||||
#:with real-part (unboxed-gensym)
|
||||
#:with imag-part (unboxed-gensym)
|
||||
#:with (bindings ...)
|
||||
(begin (log-optimization "unboxed binary inexact complex" #'op)
|
||||
#`(#,@(append (syntax->list #'(c1.bindings ... c2.bindings ... cs.bindings ... ...))
|
||||
(list #`(real-part #,(for/fold ((o #'c1.real-part))
|
||||
((e (syntax->list #'(c2.real-part cs.real-part ...))))
|
||||
#`(op.unsafe #,o #,e)))
|
||||
#`(imag-part #,(for/fold ((o #'c1.imag-part))
|
||||
((e (syntax->list #'(c2.imag-part cs.imag-part ...))))
|
||||
#`(op.unsafe #,o #,e))))))))
|
||||
(pattern (#%plain-app (~and op (~literal *))
|
||||
c1:unboxed-inexact-complex-opt-expr
|
||||
c2:unboxed-inexact-complex-opt-expr
|
||||
cs:unboxed-inexact-complex-opt-expr ...)
|
||||
#:with real-part (unboxed-gensym)
|
||||
#:with imag-part (unboxed-gensym)
|
||||
#:with (bindings ...)
|
||||
(begin (log-optimization "unboxed binary inexact complex" #'op)
|
||||
#`(c1.bindings ... c2.bindings ... cs.bindings ... ...
|
||||
;; we want to bind the intermediate results to reuse them
|
||||
;; the final results are bound to real-part and imag-part
|
||||
#,@(let loop ([o1 #'c1.real-part]
|
||||
[o2 #'c1.imag-part]
|
||||
[e1 (syntax->list #'(c2.real-part cs.real-part ...))]
|
||||
[e2 (syntax->list #'(c2.imag-part cs.imag-part ...))]
|
||||
[rs (append (map (lambda (x) (unboxed-gensym))
|
||||
(syntax->list #'(cs.real-part ...)))
|
||||
(list #'real-part))]
|
||||
[is (append (map (lambda (x) (unboxed-gensym))
|
||||
(syntax->list #'(cs.imag-part ...)))
|
||||
(list #'imag-part))]
|
||||
[res '()])
|
||||
(if (null? e1)
|
||||
(reverse res)
|
||||
(loop (car rs) (car is) (cdr e1) (cdr e2) (cdr rs) (cdr is)
|
||||
;; complex multiplication, imag part, then real part (reverse)
|
||||
(list* #`(#,(car is)
|
||||
(unsafe-fl+ (unsafe-fl* #,o2 #,(car e1))
|
||||
(unsafe-fl* #,o1 #,(car e2))))
|
||||
#`(#,(car rs)
|
||||
(unsafe-fl- (unsafe-fl* #,o1 #,(car e1))
|
||||
(unsafe-fl* #,o2 #,(car e2))))
|
||||
res)))))))
|
||||
(pattern (#%plain-app (~and op (~literal /))
|
||||
c1:unboxed-inexact-complex-opt-expr
|
||||
c2:unboxed-inexact-complex-opt-expr
|
||||
cs:unboxed-inexact-complex-opt-expr ...)
|
||||
#:with real-part (unboxed-gensym)
|
||||
#:with imag-part (unboxed-gensym)
|
||||
#:with (denominators ...)
|
||||
(for/list
|
||||
([e1 (syntax->list #'(c2.real-part cs.real-part ...))]
|
||||
[e2 (syntax->list #'(c2.imag-part cs.imag-part ...))])
|
||||
#`(#,(unboxed-gensym) (unsafe-fl+ (unsafe-fl* #,e1 #,e1) (unsafe-fl* #,e2 #,e2))))
|
||||
#:with (bindings ...)
|
||||
(begin (log-optimization "unboxed binary inexact complex" #'op)
|
||||
#`(c1.bindings ... c2.bindings ... cs.bindings ... ... denominators ...
|
||||
;; we want to bind the intermediate results to reuse them
|
||||
;; the final results are bound to real-part and imag-part
|
||||
#,@(let loop ([o1 #'c1.real-part]
|
||||
[o2 #'c1.imag-part]
|
||||
[e1 (syntax->list #'(c2.real-part cs.real-part ...))]
|
||||
[e2 (syntax->list #'(c2.imag-part cs.imag-part ...))]
|
||||
[d (map (lambda (x) (car (syntax-e x)))
|
||||
(syntax->list #'(denominators ...)))]
|
||||
[rs (append (map (lambda (x) (unboxed-gensym))
|
||||
(syntax->list #'(cs.real-part ...)))
|
||||
(list #'real-part))]
|
||||
[is (append (map (lambda (x) (unboxed-gensym))
|
||||
(syntax->list #'(cs.imag-part ...)))
|
||||
(list #'imag-part))]
|
||||
[res '()])
|
||||
(if (null? e1)
|
||||
(reverse res)
|
||||
(loop (car rs) (car is) (cdr e1) (cdr e2) (cdr d) (cdr rs) (cdr is)
|
||||
;; complex division, imag part, then real part (reverse)
|
||||
(list* #`(#,(car is)
|
||||
(unsafe-fl/ (unsafe-fl- (unsafe-fl* #,o2 #,(car e1))
|
||||
(unsafe-fl* #,o1 #,(car e2)))
|
||||
#,(car d)))
|
||||
#`(#,(car rs)
|
||||
(unsafe-fl/ (unsafe-fl+ (unsafe-fl* #,o1 #,(car e1))
|
||||
(unsafe-fl* #,o2 #,(car e2)))
|
||||
#,(car d)))
|
||||
res)))))))
|
||||
(pattern e:expr
|
||||
;; can't work on inexact reals, which are a subtype of inexact
|
||||
;; complexes, so this has to be equality
|
||||
#:when (isoftype? #'e -InexactComplex)
|
||||
#:with e* (unboxed-gensym)
|
||||
#:with real-part (unboxed-gensym)
|
||||
#:with imag-part (unboxed-gensym)
|
||||
#:with (bindings ...)
|
||||
#`((e* #,((optimize) #'e))
|
||||
(real-part (unsafe-flreal-part e*))
|
||||
(imag-part (unsafe-flimag-part e*)))))
|
||||
|
||||
(define-syntax-class inexact-complex-unary-op
|
||||
(pattern (~or (~literal real-part) (~literal flreal-part)) #:with unsafe #'unsafe-flreal-part)
|
||||
(pattern (~or (~literal imag-part) (~literal flimag-part)) #:with unsafe #'unsafe-flimag-part))
|
||||
(define binary-inexact-complex-ops
|
||||
(mk-float-tbl (list #'+ #'- #'* #'/)))
|
||||
|
||||
|
||||
(define (optimize-inexact-complex-expr e)
|
||||
(syntax-parse e #:literal-sets (kernel-literals)
|
||||
[e:inexact-complex-opt-expr
|
||||
(syntax/loc stx e.opt)]))
|
||||
|
|
@ -1,239 +1,15 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require syntax/parse (for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops racket/private/for)
|
||||
"../utils/utils.rkt" "../utils/tc-utils.rkt" unstable/match scheme/match unstable/syntax unstable/values
|
||||
(rep type-rep) syntax/id-table racket/dict
|
||||
(types abbrev type-table utils subtype))
|
||||
(provide optimize)
|
||||
(require syntax/parse
|
||||
syntax/id-table racket/dict
|
||||
unstable/match scheme/match
|
||||
(for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops racket/private/for)
|
||||
"../utils/utils.rkt" "../utils/tc-utils.rkt"
|
||||
(rep type-rep)
|
||||
(types abbrev type-table utils subtype)
|
||||
(optimizer utils fixnum float inexact-complex))
|
||||
|
||||
;; is the syntax object s's type a subtype of t?
|
||||
(define (subtypeof s t)
|
||||
(match (type-of s)
|
||||
[(tc-result1: (== t (lambda (x y) (subtype y x)))) #t] [_ #f]))
|
||||
|
||||
|
||||
(define-syntax-class float-opt-expr
|
||||
(pattern e:opt-expr
|
||||
#:when (subtypeof #'e -Flonum)
|
||||
#:with opt #'e.opt))
|
||||
(define-syntax-class int-opt-expr
|
||||
(pattern e:opt-expr
|
||||
#:when (subtypeof #'e -Integer)
|
||||
#:with opt #'e.opt))
|
||||
|
||||
;; if the result of an operation is of type float, its non float arguments
|
||||
;; can be promoted, and we can use unsafe float operations
|
||||
;; note: none of the unary operations have types where non-float arguments
|
||||
;; can result in float (as opposed to real) results
|
||||
(define-syntax-class float-arg-expr
|
||||
(pattern e:fixnum-opt-expr
|
||||
#:with opt #'(unsafe-fx->fl e.opt))
|
||||
(pattern e:int-opt-expr
|
||||
#:with opt #'(->fl e.opt))
|
||||
(pattern e:float-opt-expr
|
||||
#:with opt #'e.opt))
|
||||
|
||||
(define (mk-unsafe-tbl generic safe-pattern unsafe-pattern)
|
||||
(for/fold ([h (make-immutable-free-id-table)]) ([g generic])
|
||||
(let ([f (format-id g safe-pattern g)] [u (format-id g unsafe-pattern g)])
|
||||
(dict-set (dict-set h g u) f u))))
|
||||
|
||||
(define (mk-float-tbl generic)
|
||||
(mk-unsafe-tbl generic "fl~a" "unsafe-fl~a"))
|
||||
|
||||
(define binary-float-ops
|
||||
(mk-float-tbl (list #'+ #'- #'* #'/ #'min #'max)))
|
||||
(define binary-float-comps
|
||||
(dict-set
|
||||
(dict-set
|
||||
(mk-float-tbl (list #'= #'<= #'< #'> #'>=))
|
||||
;; not a comparison, but takes 2 floats and does not return a float,
|
||||
;; unlike binary-float-ops
|
||||
#'make-rectangular #'unsafe-make-flrectangular)
|
||||
#'make-flrectangular #'unsafe-make-flrectangular))
|
||||
(define unary-float-ops
|
||||
(mk-float-tbl (list #'abs #'sin #'cos #'tan #'asin #'acos #'atan #'log #'exp
|
||||
#'sqrt #'round #'floor #'ceiling #'truncate)))
|
||||
|
||||
(define-syntax-class (float-op tbl)
|
||||
(pattern i:id
|
||||
#:when (dict-ref tbl #'i #f)
|
||||
#:with unsafe (dict-ref tbl #'i)))
|
||||
|
||||
;; to generate temporary symbols in a predictable manner
|
||||
;; these identifiers are unique within a sequence of unboxed operations
|
||||
;; necessary to have predictable symbols to add in the hand-optimized versions
|
||||
;; of the optimizer tests (which check for equality of expanded code)
|
||||
(define *unboxed-gensym-counter* 0)
|
||||
(define (unboxed-gensym)
|
||||
(set! *unboxed-gensym-counter* (add1 *unboxed-gensym-counter*))
|
||||
(format-unique-id #'here "unboxed-gensym-~a" *unboxed-gensym-counter*))
|
||||
|
||||
(define-syntax-class inexact-complex-opt-expr
|
||||
(pattern e:opt-expr
|
||||
#:when (match (type-of #'e)
|
||||
[(tc-result1: (== -InexactComplex type-equal?)) #t] [_ #f])
|
||||
|
||||
#:with opt #'e.opt))
|
||||
;; it's faster to take apart a complex number and use unsafe operations on
|
||||
;; its parts than it is to use generic operations
|
||||
;; we keep the real and imaginary parts unboxed as long as we stay within
|
||||
;; complex operations
|
||||
(define-syntax-class unboxed-inexact-complex-opt-expr
|
||||
(pattern (#%plain-app (~and (~var op (float-op binary-inexact-complex-ops)) (~or (~literal +) (~literal -)))
|
||||
c1:unboxed-inexact-complex-opt-expr
|
||||
c2:unboxed-inexact-complex-opt-expr
|
||||
cs:unboxed-inexact-complex-opt-expr ...)
|
||||
#:with real-part (unboxed-gensym)
|
||||
#:with imag-part (unboxed-gensym)
|
||||
#:with (bindings ...)
|
||||
(begin (log-optimization "unboxed binary inexact complex" #'op)
|
||||
#`(#,@(append (syntax->list #'(c1.bindings ... c2.bindings ... cs.bindings ... ...))
|
||||
(list #`(real-part #,(for/fold ((o #'c1.real-part))
|
||||
((e (syntax->list #'(c2.real-part cs.real-part ...))))
|
||||
#`(op.unsafe #,o #,e)))
|
||||
#`(imag-part #,(for/fold ((o #'c1.imag-part))
|
||||
((e (syntax->list #'(c2.imag-part cs.imag-part ...))))
|
||||
#`(op.unsafe #,o #,e))))))))
|
||||
(pattern (#%plain-app (~and op (~literal *))
|
||||
c1:unboxed-inexact-complex-opt-expr
|
||||
c2:unboxed-inexact-complex-opt-expr
|
||||
cs:unboxed-inexact-complex-opt-expr ...)
|
||||
#:with real-part (unboxed-gensym)
|
||||
#:with imag-part (unboxed-gensym)
|
||||
#:with (bindings ...)
|
||||
(begin (log-optimization "unboxed binary inexact complex" #'op)
|
||||
#`(c1.bindings ... c2.bindings ... cs.bindings ... ...
|
||||
;; we want to bind the intermediate results to reuse them
|
||||
;; the final results are bound to real-part and imag-part
|
||||
#,@(let loop ([o1 #'c1.real-part]
|
||||
[o2 #'c1.imag-part]
|
||||
[e1 (syntax->list #'(c2.real-part cs.real-part ...))]
|
||||
[e2 (syntax->list #'(c2.imag-part cs.imag-part ...))]
|
||||
[rs (append (map (lambda (x) (unboxed-gensym))
|
||||
(syntax->list #'(cs.real-part ...)))
|
||||
(list #'real-part))]
|
||||
[is (append (map (lambda (x) (unboxed-gensym))
|
||||
(syntax->list #'(cs.imag-part ...)))
|
||||
(list #'imag-part))]
|
||||
[res '()])
|
||||
(if (null? e1)
|
||||
(reverse res)
|
||||
(loop (car rs) (car is) (cdr e1) (cdr e2) (cdr rs) (cdr is)
|
||||
;; complex multiplication, imag part, then real part (reverse)
|
||||
(list* #`(#,(car is)
|
||||
(unsafe-fl+ (unsafe-fl* #,o2 #,(car e1))
|
||||
(unsafe-fl* #,o1 #,(car e2))))
|
||||
#`(#,(car rs)
|
||||
(unsafe-fl- (unsafe-fl* #,o1 #,(car e1))
|
||||
(unsafe-fl* #,o2 #,(car e2))))
|
||||
res)))))))
|
||||
(pattern (#%plain-app (~and op (~literal /))
|
||||
c1:unboxed-inexact-complex-opt-expr
|
||||
c2:unboxed-inexact-complex-opt-expr
|
||||
cs:unboxed-inexact-complex-opt-expr ...)
|
||||
#:with real-part (unboxed-gensym)
|
||||
#:with imag-part (unboxed-gensym)
|
||||
#:with (denominators ...)
|
||||
(for/list
|
||||
([e1 (syntax->list #'(c2.real-part cs.real-part ...))]
|
||||
[e2 (syntax->list #'(c2.imag-part cs.imag-part ...))])
|
||||
#`(#,(unboxed-gensym) (unsafe-fl+ (unsafe-fl* #,e1 #,e1) (unsafe-fl* #,e2 #,e2))))
|
||||
#:with (bindings ...)
|
||||
(begin (log-optimization "unboxed binary inexact complex" #'op)
|
||||
#`(c1.bindings ... c2.bindings ... cs.bindings ... ... denominators ...
|
||||
;; we want to bind the intermediate results to reuse them
|
||||
;; the final results are bound to real-part and imag-part
|
||||
#,@(let loop ([o1 #'c1.real-part]
|
||||
[o2 #'c1.imag-part]
|
||||
[e1 (syntax->list #'(c2.real-part cs.real-part ...))]
|
||||
[e2 (syntax->list #'(c2.imag-part cs.imag-part ...))]
|
||||
[d (map (lambda (x) (car (syntax-e x)))
|
||||
(syntax->list #'(denominators ...)))]
|
||||
[rs (append (map (lambda (x) (unboxed-gensym))
|
||||
(syntax->list #'(cs.real-part ...)))
|
||||
(list #'real-part))]
|
||||
[is (append (map (lambda (x) (unboxed-gensym))
|
||||
(syntax->list #'(cs.imag-part ...)))
|
||||
(list #'imag-part))]
|
||||
[res '()])
|
||||
(if (null? e1)
|
||||
(reverse res)
|
||||
(loop (car rs) (car is) (cdr e1) (cdr e2) (cdr d) (cdr rs) (cdr is)
|
||||
;; complex division, imag part, then real part (reverse)
|
||||
(list* #`(#,(car is)
|
||||
(unsafe-fl/ (unsafe-fl- (unsafe-fl* #,o2 #,(car e1))
|
||||
(unsafe-fl* #,o1 #,(car e2)))
|
||||
#,(car d)))
|
||||
#`(#,(car rs)
|
||||
(unsafe-fl/ (unsafe-fl+ (unsafe-fl* #,o1 #,(car e1))
|
||||
(unsafe-fl* #,o2 #,(car e2)))
|
||||
#,(car d)))
|
||||
res)))))))
|
||||
(pattern e:opt-expr
|
||||
;; can't work on inexact reals, which are a subtype of inexact
|
||||
;; complexes, so this has to be equality
|
||||
#:when (match (type-of #'e)
|
||||
[(tc-result1: (== -InexactComplex type-equal?)) #t] [_ #f])
|
||||
#:with e* (unboxed-gensym)
|
||||
#:with real-part (unboxed-gensym)
|
||||
#:with imag-part (unboxed-gensym)
|
||||
#:with (bindings ...)
|
||||
#'((e* e.opt)
|
||||
(real-part (unsafe-flreal-part e*))
|
||||
(imag-part (unsafe-flimag-part e*)))))
|
||||
|
||||
(define-syntax-class inexact-complex-unary-op
|
||||
(pattern (~or (~literal real-part) (~literal flreal-part)) #:with unsafe #'unsafe-flreal-part)
|
||||
(pattern (~or (~literal imag-part) (~literal flimag-part)) #:with unsafe #'unsafe-flimag-part))
|
||||
(define binary-inexact-complex-ops
|
||||
(mk-float-tbl (list #'+ #'- #'* #'/)))
|
||||
|
||||
(define-syntax-class fixnum-opt-expr
|
||||
(pattern e:opt-expr
|
||||
#:when (subtypeof #'e -Fixnum)
|
||||
#:with opt #'e.opt))
|
||||
(define-syntax-class nonzero-fixnum-opt-expr
|
||||
(pattern e:opt-expr
|
||||
#:when (match (type-of #'e)
|
||||
[(tc-result1: (== -PositiveFixnum type-equal?)) #t]
|
||||
[(tc-result1: (== -NegativeFixnum type-equal?)) #t]
|
||||
[_ #f])
|
||||
#:with opt #'e.opt))
|
||||
|
||||
(define (mk-fixnum-tbl generic)
|
||||
(mk-unsafe-tbl generic "fx~a" "unsafe-fx~a"))
|
||||
|
||||
;; due to undefined behavior when results are out of the fixnum range, only some
|
||||
;; fixnum operations can be optimized
|
||||
;; the following must be closed on fixnums
|
||||
(define binary-fixnum-ops
|
||||
(dict-set
|
||||
(dict-set
|
||||
(dict-set
|
||||
(dict-set
|
||||
(dict-set
|
||||
(dict-set
|
||||
(mk-fixnum-tbl (list #'= #'<= #'< #'> #'>= #'min #'max))
|
||||
#'bitwise-and #'unsafe-fxand)
|
||||
#'fxand #'unsafe-fxand)
|
||||
#'bitwise-ior #'unsafe-fxior)
|
||||
#'fxior #'unsafe-fxior)
|
||||
#'bitwise-xor #'unsafe-fxxor)
|
||||
#'fxxor #'unsafe-fxxor))
|
||||
(define-syntax-class fixnum-unary-op
|
||||
(pattern (~or (~literal bitwise-not) (~literal fxnot)) #:with unsafe #'unsafe-fxnot)
|
||||
(pattern (~or (~literal abs) (~literal fxabs)) #:with unsafe #'unsafe-fxabs))
|
||||
;; closed on fixnums, but 2nd argument must not be 0
|
||||
(define-syntax-class nonzero-fixnum-binary-op
|
||||
(pattern (~or (~literal quotient) (~literal fxquotient)) #:with unsafe #'unsafe-fxquotient)
|
||||
(pattern (~or (~literal modulo) (~literal fxmodulo)) #:with unsafe #'unsafe-fxmodulo)
|
||||
(pattern (~or (~literal remainder) (~literal fxremainder)) #:with unsafe #'unsafe-fxremainder))
|
||||
|
||||
(define-syntax-class (fixnum-op tbl)
|
||||
(pattern i:id
|
||||
#:when (dict-ref tbl #'i #f)
|
||||
#:with unsafe (dict-ref tbl #'i)))
|
||||
(provide optimize-top)
|
||||
|
||||
|
||||
(define-syntax-class pair-opt-expr
|
||||
|
|
@ -272,39 +48,29 @@
|
|||
(pattern e:opt-expr*
|
||||
#:with opt (syntax-recertify #'e.opt this-syntax (current-code-inspector) #f)))
|
||||
|
||||
(define *log-optimizations?* #f)
|
||||
(define *log-optimizatons-to-log-file?* #f)
|
||||
(define *optimization-log-file* "opt-log")
|
||||
(define (log-optimization kind stx)
|
||||
(if *log-optimizations?*
|
||||
(printf "~a line ~a col ~a - ~a - ~a\n"
|
||||
(syntax-source stx) (syntax-line stx) (syntax-column stx)
|
||||
(syntax->datum stx)
|
||||
kind)
|
||||
#t))
|
||||
|
||||
;; unlike their safe counterparts, unsafe binary operators can only take 2 arguments
|
||||
(define (n-ary->binary op arg1 arg2 rest)
|
||||
(for/fold ([o arg1])
|
||||
([e (syntax->list #`(#,arg2 #,@rest))])
|
||||
#`(#,op #,o #,e)))
|
||||
|
||||
(define-syntax-class opt-expr*
|
||||
#:literal-sets (kernel-literals)
|
||||
|
||||
;; interesting cases, where something is optimized
|
||||
(pattern (~and res (#%plain-app (~var op (float-op unary-float-ops)) f:float-opt-expr))
|
||||
#:when (subtypeof #'res -Flonum)
|
||||
#:when (subtypeof? #'res -Flonum)
|
||||
#:with opt
|
||||
(begin (log-optimization "unary float" #'op)
|
||||
#'(op.unsafe f.opt)))
|
||||
(pattern (~and res (#%plain-app (~var op (float-op binary-float-ops)) f1:float-arg-expr f2:float-arg-expr fs:float-arg-expr ...))
|
||||
(pattern (~and res (#%plain-app (~var op (float-op binary-float-ops))
|
||||
f1:float-arg-expr
|
||||
f2:float-arg-expr
|
||||
fs:float-arg-expr ...))
|
||||
;; if the result is a float, we can coerce integers to floats and optimize
|
||||
#:when (subtypeof #'res -Flonum)
|
||||
#:when (subtypeof? #'res -Flonum)
|
||||
#:with opt
|
||||
(begin (log-optimization "binary float" #'op)
|
||||
(n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...))))
|
||||
(pattern (~and res (#%plain-app (~var op (float-op binary-float-comps)) f1:float-opt-expr f2:float-opt-expr fs:float-opt-expr ...))
|
||||
(pattern (~and res (#%plain-app (~var op (float-op binary-float-comps))
|
||||
f1:float-opt-expr
|
||||
f2:float-opt-expr
|
||||
fs:float-opt-expr ...))
|
||||
#:with opt
|
||||
(begin (log-optimization "binary float comp" #'op)
|
||||
(n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...))))
|
||||
|
|
@ -313,11 +79,16 @@
|
|||
#:with opt
|
||||
(begin (log-optimization "unary fixnum" #'op)
|
||||
#'(op.unsafe n.opt)))
|
||||
(pattern (#%plain-app (~var op (fixnum-op binary-fixnum-ops)) n1:fixnum-opt-expr n2:fixnum-opt-expr ns:fixnum-opt-expr ...)
|
||||
(pattern (#%plain-app (~var op (fixnum-op binary-fixnum-ops))
|
||||
n1:fixnum-opt-expr
|
||||
n2:fixnum-opt-expr
|
||||
ns:fixnum-opt-expr ...)
|
||||
#:with opt
|
||||
(begin (log-optimization "binary fixnum" #'op)
|
||||
(n-ary->binary #'op.unsafe #'n1.opt #'n2.opt #'(ns.opt ...))))
|
||||
(pattern (#%plain-app op:nonzero-fixnum-binary-op n1:fixnum-opt-expr n2:nonzero-fixnum-opt-expr)
|
||||
(pattern (#%plain-app op:nonzero-fixnum-binary-op
|
||||
n1:fixnum-opt-expr
|
||||
n2:nonzero-fixnum-opt-expr)
|
||||
#:with opt
|
||||
(begin (log-optimization "binary nonzero fixnum" #'op)
|
||||
#'(op.unsafe n1.opt n2.opt)))
|
||||
|
|
@ -326,11 +97,12 @@
|
|||
#:with opt
|
||||
(begin (log-optimization "unary inexact complex" #'op)
|
||||
#'(op.unsafe n.opt)))
|
||||
(pattern (~and exp (#%plain-app (~var op (float-op binary-inexact-complex-ops)) e:inexact-complex-opt-expr ...))
|
||||
(pattern (~and exp (#%plain-app (~var op (float-op binary-inexact-complex-ops))
|
||||
e:inexact-complex-opt-expr ...))
|
||||
#:with exp*:unboxed-inexact-complex-opt-expr #'exp
|
||||
#:with opt
|
||||
(begin (log-optimization "unboxed inexact complex" #'exp)
|
||||
(begin (set! *unboxed-gensym-counter* 0)
|
||||
(begin (reset-unboxed-gensym)
|
||||
#'(let* (exp*.bindings ...)
|
||||
(unsafe-make-flrectangular exp*.real-part exp*.imag-part)))))
|
||||
|
||||
|
|
@ -438,17 +210,19 @@
|
|||
(pattern other:expr
|
||||
#:with opt #'other))
|
||||
|
||||
(define (optimize stx)
|
||||
(define (optimize-top stx)
|
||||
(let ((port (if (and *log-optimizations?*
|
||||
*log-optimizatons-to-log-file?*)
|
||||
(open-output-file *optimization-log-file*
|
||||
#:exists 'append)
|
||||
(current-output-port))))
|
||||
(begin0
|
||||
(parameterize ([current-output-port port])
|
||||
(syntax-parse stx #:literal-sets (kernel-literals)
|
||||
[e:opt-expr
|
||||
(syntax/loc stx e.opt)]))
|
||||
(parameterize ([current-output-port port]
|
||||
[optimize (lambda (stx)
|
||||
(syntax-parse stx #:literal-sets (kernel-literals)
|
||||
[e:opt-expr
|
||||
(syntax/loc stx e.opt)]))])
|
||||
((optimize) stx))
|
||||
(if (and *log-optimizations?*
|
||||
*log-optimizatons-to-log-file?*)
|
||||
(close-output-port port)
|
||||
|
|
|
|||
64
collects/typed-scheme/optimizer/utils.rkt
Normal file
64
collects/typed-scheme/optimizer/utils.rkt
Normal file
|
|
@ -0,0 +1,64 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require unstable/match scheme/match
|
||||
racket/dict syntax/id-table unstable/syntax
|
||||
(for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops)
|
||||
"../utils/utils.rkt"
|
||||
(types abbrev type-table utils subtype)
|
||||
(rep type-rep))
|
||||
|
||||
(provide log-optimization *log-optimizations?* *log-optimizatons-to-log-file?* *optimization-log-file*
|
||||
subtypeof? isoftype?
|
||||
mk-unsafe-tbl
|
||||
n-ary->binary
|
||||
unboxed-gensym reset-unboxed-gensym
|
||||
optimize)
|
||||
|
||||
|
||||
(define *log-optimizations?* #f)
|
||||
(define *log-optimizatons-to-log-file?* #f)
|
||||
(define *optimization-log-file* "opt-log")
|
||||
(define (log-optimization kind stx)
|
||||
(if *log-optimizations?*
|
||||
(printf "~a line ~a col ~a - ~a - ~a\n"
|
||||
(syntax-source stx) (syntax-line stx) (syntax-column stx)
|
||||
(syntax->datum stx)
|
||||
kind)
|
||||
#t))
|
||||
|
||||
;; is the syntax object s's type a subtype of t?
|
||||
(define (subtypeof? s t)
|
||||
(match (type-of s)
|
||||
[(tc-result1: (== t (lambda (x y) (subtype y x)))) #t] [_ #f]))
|
||||
;; similar, but with type equality
|
||||
(define (isoftype? s t)
|
||||
(match (type-of s)
|
||||
[(tc-result1: (== t type-equal?)) #t] [_ #f]))
|
||||
|
||||
;; generates a table matching safe to unsafe promitives
|
||||
(define (mk-unsafe-tbl generic safe-pattern unsafe-pattern)
|
||||
(for/fold ([h (make-immutable-free-id-table)]) ([g generic])
|
||||
(let ([f (format-id g safe-pattern g)] [u (format-id g unsafe-pattern g)])
|
||||
(dict-set (dict-set h g u) f u))))
|
||||
|
||||
;; unlike their safe counterparts, unsafe binary operators can only take 2 arguments
|
||||
(define (n-ary->binary op arg1 arg2 rest)
|
||||
(for/fold ([o arg1])
|
||||
([e (syntax->list #`(#,arg2 #,@rest))])
|
||||
#`(#,op #,o #,e)))
|
||||
|
||||
;; to generate temporary symbols in a predictable manner
|
||||
;; these identifiers are unique within a sequence of unboxed operations
|
||||
;; necessary to have predictable symbols to add in the hand-optimized versions
|
||||
;; of the optimizer tests (which check for equality of expanded code)
|
||||
(define *unboxed-gensym-counter* 0)
|
||||
(define (unboxed-gensym)
|
||||
(set! *unboxed-gensym-counter* (add1 *unboxed-gensym-counter*))
|
||||
(format-unique-id #'here "unboxed-gensym-~a" *unboxed-gensym-counter*))
|
||||
(define (reset-unboxed-gensym)
|
||||
(set! *unboxed-gensym-counter* 0))
|
||||
|
||||
;; to avoid mutually recursive syntax classes
|
||||
;; will be set to the actual optimization function at the entry point
|
||||
;; of the optimizer
|
||||
(define optimize (make-parameter #f))
|
||||
|
|
@ -44,7 +44,7 @@
|
|||
[(optimized-body ...)
|
||||
;; do we optimize?
|
||||
(if (optimize?)
|
||||
(begin0 (map optimize (syntax->list #'transformed-body))
|
||||
(begin0 (map optimize-top (syntax->list #'transformed-body))
|
||||
(do-time "Optimized"))
|
||||
#'transformed-body)])
|
||||
;; reconstruct the module with the extra code
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user