added #:commit to TR optimizer stxclasses

original commit: 0c4f82a434daa05decb6f4c92bede7ef11d5b998

collects/typed-scheme/optimizer/apply.rkt

@@ -12,12 +12,14 @@
 (provide apply-opt-expr)
 
 (define-syntax-class apply-op
+  #:commit
   #:literals (+ *)
   (pattern + #:with identity #'0)
   (pattern * #:with identity #'1))
 
 (define-syntax-class apply-opt-expr
-		     #:literals (k:apply map #%plain-app #%app)
+  #:commit
+  #:literals (k:apply map #%plain-app #%app)
   (pattern (#%plain-app k:apply op:apply-op (#%plain-app map f l))
            #:with opt
            (begin (reset-unboxed-gensym)

collects/typed-scheme/optimizer/box.rkt

@@ -11,6 +11,7 @@
 (provide box-opt-expr)
 
 (define-syntax-class box-expr
+  #:commit
   (pattern e:expr
            #:when (match (type-of #'e)
                     [(tc-result1: (Box: _)) #t]
@@ -18,11 +19,13 @@
            #:with opt ((optimize) #'e)))
 
 (define-syntax-class box-op
+  #:commit
   ;; we need the * versions of these unsafe operations to be chaperone-safe
   (pattern (~literal unbox)    #:with unsafe #'unsafe-unbox*)
   (pattern (~literal set-box!) #:with unsafe #'unsafe-set-box*!))
 
 (define-syntax-class box-opt-expr
+  #:commit
   (pattern (#%plain-app op:box-op b:box-expr new:expr ...)
            #:with opt
            (begin (log-optimization "box" #'op)

collects/typed-scheme/optimizer/dead-code.rkt

@@ -9,6 +9,7 @@
 (provide dead-code-opt-expr)
 
 (define-syntax-class dead-code-opt-expr
+  #:commit
   ;; if one of the brances of an if is unreachable, we can eliminate it
   ;; we have to keep the test, in case it has side effects
   (pattern (if tst:expr thn:expr els:expr)

collects/typed-scheme/optimizer/fixnum.rkt

@@ -30,30 +30,36 @@
     #'bitwise-xor #'unsafe-fxxor)
    #'fxxor #'unsafe-fxxor))
 (define-syntax-class fixnum-unary-op
+  #:commit
   (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
+  #:commit
   (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)
+  #:commit
   (pattern i:id
            #:when (dict-ref tbl #'i #f)
            #:with unsafe (dict-ref tbl #'i)))
 
 
 (define-syntax-class fixnum-expr
+  #:commit
   (pattern e:expr
            #:when (subtypeof? #'e -Fixnum)
            #:with opt ((optimize) #'e)))
 (define-syntax-class nonzero-fixnum-expr
+  #:commit
   (pattern e:expr
            #:when (or (isoftype? #'e -PositiveFixnum) (isoftype? #'e -NegativeFixnum))
            #:with opt ((optimize) #'e)))
 
 (define-syntax-class fixnum-opt-expr
+  #:commit
   (pattern (#%plain-app op:fixnum-unary-op n:fixnum-expr)
            #:with opt
            (begin (log-optimization "unary fixnum" #'op)

collects/typed-scheme/optimizer/float.rkt

@@ -28,19 +28,23 @@
                       #'sqrt #'round #'floor #'ceiling #'truncate)))
 
 (define-syntax-class (float-op tbl)
+  #:commit
   (pattern i:id
            #:when (dict-ref tbl #'i #f)
            #:with unsafe (dict-ref tbl #'i)))
 
 (define-syntax-class float-expr
+  #:commit
   (pattern e:expr
            #:when (subtypeof? #'e -Flonum)
            #:with opt ((optimize) #'e)))
 (define-syntax-class int-expr
+  #:commit
   (pattern e:expr
            #:when (subtypeof? #'e -Integer)
            #:with opt ((optimize) #'e)))
 (define-syntax-class real-expr
+  #:commit
   (pattern e:expr
            #:when (subtypeof? #'e -Real)
            #:with opt ((optimize) #'e)))
@@ -48,6 +52,7 @@
 
 ;; generates coercions to floats
 (define-syntax-class float-coerce-expr
+  #:commit
   (pattern e:float-arg-expr
            #:with opt #'e.opt)
   (pattern e:real-expr
@@ -59,6 +64,7 @@
 ;; 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
+  #:commit
   ;; we can convert literals right away
   (pattern (quote n)
            #:when (exact-integer? (syntax->datum #'n))
@@ -72,6 +78,7 @@
            #:with opt #'e.opt))
 
 (define-syntax-class float-opt-expr
+  #:commit
   (pattern (#%plain-app (~var op (float-op unary-float-ops)) f:float-expr)
            #:when (subtypeof? this-syntax -Flonum)
            #:with opt

collects/typed-scheme/optimizer/inexact-complex.rkt

@@ -338,23 +338,28 @@
            #:with imag-binding #f))
 
 (define-syntax-class inexact-complex-unary-op
+  #:commit
   (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-syntax-class inexact-complex-op
+  #:commit
   (pattern (~or (~literal +) (~literal -) (~literal *) (~literal /) (~literal conjugate))))
 
 (define-syntax-class inexact-complex->float-op
+  #:commit
   (pattern (~or (~literal magnitude)
                 (~literal real-part) (~literal flreal-part) (~literal unsafe-flreal-part)
                 (~literal imag-part) (~literal flimag-part) (~literal unsafe-flimag-part))))
 
 (define-syntax-class inexact-complex-expr
+  #:commit
   (pattern e:expr
            #:when (isoftype? #'e -InexactComplex)
            #:with opt ((optimize) #'e)))
 
 (define-syntax-class inexact-complex-opt-expr
+  #:commit
 
   ;; we can optimize taking the real of imag part of an unboxed complex
   ;; hopefully, the compiler can eliminate unused bindings for the other part if it's not used
@@ -401,6 +406,7 @@
            #:with opt #'e.opt))
 
 (define-syntax-class inexact-complex-arith-opt-expr
+  #:commit
   
   (pattern (#%plain-app op:inexact-complex->float-op e:expr ...)
            #:when (subtypeof? this-syntax -Flonum)
@@ -443,6 +449,7 @@
 ;; and the optimized version of the operator. operators are optimized elsewhere
 ;; to benefit from local information
 (define-syntax-class (inexact-complex-call-site-opt-expr unboxed-info opt-operator)
+  #:commit
   ;; call site of a function with unboxed parameters
   ;; the calling convention is: real parts of unboxed, imag parts, boxed
   (pattern (#%plain-app op:expr args:expr ...)

collects/typed-scheme/optimizer/number.rkt

@@ -8,6 +8,7 @@
 (provide number-opt-expr)
 
 (define-syntax-class number-opt-expr
+  #:commit
   ;; these cases are all identity
   (pattern (#%plain-app (~and op (~or (~literal +) (~literal *) (~literal min) (~literal max)))
                         f:expr)

collects/typed-scheme/optimizer/optimizer.rkt

@@ -15,10 +15,12 @@
 
 
 (define-syntax-class opt-expr
+  #:commit
   (pattern e:opt-expr*
            #:with opt (syntax-recertify #'e.opt this-syntax (current-code-inspector) #f)))
 
 (define-syntax-class opt-expr*
+  #:commit
   #:literal-sets (kernel-literals)
 
   ;; interesting cases, where something is optimized

collects/typed-scheme/optimizer/pair.rkt

@@ -13,9 +13,11 @@
 
 
 (define-syntax-class pair-unary-op
+  #:commit
   (pattern (~literal car) #:with unsafe #'unsafe-car)
   (pattern (~literal cdr) #:with unsafe #'unsafe-cdr))
 (define-syntax-class mpair-op
+  #:commit
   (pattern (~literal mcar) #:with unsafe #'unsafe-mcar)
   (pattern (~literal mcdr) #:with unsafe #'unsafe-mcdr)
   (pattern (~literal set-mcar!) #:with unsafe #'unsafe-set-mcar!)
@@ -23,12 +25,14 @@
 
 
 (define-syntax-class pair-expr
+  #:commit
   (pattern e:expr
            #:when (match (type-of #'e) ; type of the operand
                     [(tc-result1: (Pair: _ _)) #t]
                     [_ #f])
            #:with opt ((optimize) #'e)))
 (define-syntax-class mpair-expr
+  #:commit
   (pattern e:expr
            #:when (match (type-of #'e) ; type of the operand
                     [(tc-result1: (MPair: _ _)) #t]
@@ -36,6 +40,7 @@
            #:with opt ((optimize) #'e)))
 
 (define-syntax-class pair-opt-expr
+  #:commit
   (pattern (#%plain-app op:pair-unary-op p:pair-expr)
            #:with opt
            (begin (log-optimization "unary pair" #'op)

collects/typed-scheme/optimizer/sequence.rkt

@@ -13,6 +13,7 @@
 
 
 (define-syntax-class list-expr
+  #:commit
   (pattern e:expr
            #:when (match (type-of #'e)
                     [(tc-result1: (Listof: _)) #t]
@@ -22,6 +23,7 @@
 
 ;; unlike other vector optimizations, this works on unknown-length vectors
 (define-syntax-class vector-expr
+  #:commit
   (pattern e:expr
            #:when (match (type-of #'e)
                     [(tc-result1: (Vector: _)) #t]
@@ -30,6 +32,7 @@
            #:with opt ((optimize) #'e)))
 
 (define-syntax-class sequence-opt-expr
+  #:commit
   ;; if we're iterating (with the for macros) over something we know is a list,
   ;; we can generate code that would be similar to if in-list had been used
   (pattern (#%plain-app op:id _ l)

collects/typed-scheme/optimizer/string.rkt

@@ -9,15 +9,18 @@
 (provide string-opt-expr string-expr bytes-expr)
 
 (define-syntax-class string-expr
+  #:commit
   (pattern e:expr
            #:when (isoftype? #'e -String)
            #:with opt ((optimize) #'e)))
 (define-syntax-class bytes-expr
+  #:commit
   (pattern e:expr
            #:when (isoftype? #'e -Bytes)
            #:with opt ((optimize) #'e)))
 
 (define-syntax-class string-opt-expr
+  #:commit
   (pattern (#%plain-app (~literal string-length) s:string-expr)
            #:with opt
            (begin (log-optimization "string-length" #'op)

collects/typed-scheme/optimizer/struct.rkt

@@ -12,6 +12,7 @@
 (provide struct-opt-expr)
 
 (define-syntax-class struct-opt-expr
+  #:commit
   ;; we can always optimize struct accessors and mutators
   ;; if they typecheck, they're safe
   (pattern (#%plain-app op:id s:expr v:expr ...)

collects/typed-scheme/optimizer/unboxed-let.rkt

@@ -14,6 +14,7 @@
 ;; possibly replace bindings of complex numbers by bindings of their 2 components
 ;; useful for intermediate results used more than once and for loop variables
 (define-syntax-class unboxed-let-opt-expr
+  #:commit
   (pattern e:app-of-unboxed-let-opt-expr
            #:with opt #'e.opt)
   (pattern (~var e (unboxed-let-opt-expr-internal #f))
@@ -24,6 +25,7 @@
 ;; escapes in the operator position of a call site we control (here)
 ;; we can extend unboxing
 (define-syntax-class app-of-unboxed-let-opt-expr
+  #:commit
   #:literal-sets (kernel-literals)
   (pattern (#%plain-app
             (~and let-e ((~literal letrec-values)
@@ -44,6 +46,7 @@
 ;; detects which let bindings can be unboxed, same for arguments of let-bound
 ;; functions
 (define-syntax-class (unboxed-let-opt-expr-internal let-loop?)
+  #:commit
   #:literal-sets (kernel-literals)
   (pattern (letk:let-like-keyword ((~and clause (lhs rhs ...)) ...)
                                   body:expr ...)
@@ -137,6 +140,7 @@
                       #,@(map (optimize) (syntax->list #'(body ...)))))))
 
 (define-splicing-syntax-class let-like-keyword
+  #:commit
   #:literal-sets (kernel-literals)
   (pattern (~literal let-values)
            #:with (key ...) #'(let*-values))
@@ -261,6 +265,7 @@
 
 ;; let clause whose rhs is going to be unboxed (turned into multiple bindings)
 (define-syntax-class unboxed-let-clause
+  #:commit
   (pattern ((v:id) rhs:unboxed-inexact-complex-opt-expr)
            #:with id #'v
            #:with real-binding #'rhs.real-binding
@@ -271,6 +276,7 @@
 ;; these arguments may be unboxed
 ;; the new function will have all the unboxed arguments first, then all the boxed
 (define-syntax-class unboxed-fun-clause
+  #:commit
   (pattern ((v:id) (#%plain-lambda params body:expr ...))
            #:with id #'v
            #:with unboxed-info (dict-ref unboxed-funs-table #'v #f)
@@ -311,5 +317,6 @@
                               (cons (car params) boxed))]))))))
 
 (define-syntax-class opt-let-clause
+  #:commit
   (pattern (vs rhs:expr)
            #:with res #`(vs #,((optimize) #'rhs))))

collects/typed-scheme/optimizer/vector.rkt

@@ -12,11 +12,13 @@
 
 
 (define-syntax-class vector-op
+  #:commit
   ;; we need the * versions of these unsafe operations to be chaperone-safe
   (pattern (~literal vector-ref)  #:with unsafe #'unsafe-vector*-ref)
   (pattern (~literal vector-set!) #:with unsafe #'unsafe-vector*-set!))
 
 (define-syntax-class vector-expr
+  #:commit
   (pattern e:expr
            #:when (match (type-of #'e)
                     [(tc-result1: (HeterogenousVector: _)) #t]
@@ -24,6 +26,7 @@
            #:with opt ((optimize) #'e)))
 
 (define-syntax-class vector-opt-expr
+  #:commit
   ;; vector-length of a known-length vector
   (pattern (#%plain-app (~and op (~or (~literal vector-length)
                                       (~literal unsafe-vector-length)