Make pair-opt cleaner.

original commit: fe35cc096c59934461d89e5814c71e068d55ad94

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/pair.rkt

@@ -3,6 +3,7 @@
 (require syntax/parse syntax/stx
          racket/match
          (for-template racket/base racket/unsafe/ops racket/list)
+         (for-syntax racket/base syntax/parse racket/syntax)
          "../utils/utils.rkt"
          (utils tc-utils)
          (rep type-rep)
@@ -12,17 +13,16 @@
 
 (provide pair-opt-expr)
 
+(define-unsafe-syntax-class car)
+(define-unsafe-syntax-class cdr)
+(define-unsafe-syntax-class mcar)
+(define-unsafe-syntax-class mcdr)
+(define-unsafe-syntax-class set-mcar!)
+(define-unsafe-syntax-class set-mcdr!)
 
-(define-syntax-class pair-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!)
-  (pattern (~literal set-mcdr!) #:with unsafe #'unsafe-set-mcdr!))
+
+(define-merged-syntax-class pair-op (car^ cdr^))
+(define-merged-syntax-class mpair-op (mcar^ mcdr^ set-mcar!^ set-mcdr!^))
 
 
 (define (has-pair-type? e)
@@ -40,33 +40,28 @@
    "According to its type, the highlighted list could be empty. Access to it cannot be safely optimized. To fix this, restrict the type to non-empty lists, maybe by wrapping this expression in a check for non-emptiness."
    stx irritant))
 
-(define pair-opt-msg "Pair check elimination.")
-
-(define (log-pair-opt stx)
-  (log-optimization "pair" pair-opt-msg stx))
+(define-syntax-rule (log-pair-opt)
+  (log-opt "pair" "Pair check elimination."))
 
 (define-syntax-class pair-opt-expr
   #:commit
-  (pattern e:pair-derived-opt-expr
-           ;; no logging here, redundant with actual pair opt
-           #:with opt #'e.opt)
-  (pattern (#%plain-app op:pair-op p:expr)
-           #:when (or (has-pair-type? #'p)
-                      ;; in this case, we have a potentially empty list, but
-                      ;; it has to be a list, otherwise, there would have been
-                      ;; a type error
-                      (begin (log-pair-missed-opt this-syntax #'p) #f))
-           #:with opt
-           (begin (log-pair-opt this-syntax)
-                  (add-disappeared-use #'op)
-                  #`(op.unsafe #,((optimize) #'p))))
-  (pattern (#%plain-app op:mpair-op p:expr e:expr ...)
-           #:when (or (has-mpair-type? #'p)
-                      (begin (log-pair-missed-opt this-syntax #'p) #f))
-           #:with opt
-           (begin (log-pair-opt this-syntax)
-                  (add-disappeared-use #'op)
-                  #`(op.unsafe #,@(stx-map (optimize) #'(p e ...))))))
+  #:attributes (opt)
+
+  ;; no logging here, redundant with actual pair opt
+  (pattern :pair-derived-opt-expr)
+  (pattern (#%plain-app op:pair-op p:opt-expr)
+    #:when (or (has-pair-type? #'p)
+               ;; in this case, we have a potentially empty list, but
+               ;; it has to be a list, otherwise, there would have been
+               ;; a type error
+               (begin (log-pair-missed-opt this-syntax #'p) #f))
+    #:do [(log-pair-opt)]
+    #:with opt #'(op.unsafe p.opt))
+  (pattern (#%plain-app op:mpair-op p:opt-expr e:opt-expr ...)
+    #:when (or (has-mpair-type? #'p)
+               (begin (log-pair-missed-opt this-syntax #'p) #f))
+    #:do [(log-pair-opt)]
+    #:with opt #'(op.unsafe p.opt e.opt ...)))
 
 
 ;; change the source location of a given syntax object
@@ -77,29 +72,32 @@
 ;; we can optimize
 
 ;; accessors is a list of syntax objects, all #'car or #'cdr
-(define (gen-alt accessors stx)
-  (syntax-parse stx
-    [(#%plain-app op arg)
-     (define (gen-alt-helper accessors)
-       (if (null? accessors)
-           #'arg
-           (quasisyntax/loc stx
-             (#%plain-app #,(relocate (car accessors) stx)
-                          #,(gen-alt-helper (cdr accessors))))))
-     (let ((ty  (type-of stx))
-           (obj (gen-alt-helper accessors)))
-       ;; we're calling the typechecker, but this is just a shortcut, we're
-       ;; still conceptually single pass (we're not iterating). we could get
-       ;; the same result by statically destructing the types.
-       (tc-expr/check obj ty)
-       obj)]))
+(define (gen-alt accessors op arg stx)
+  (define (gen-alt-helper accessors)
+    (for/fold [(accum arg)] [(acc (reverse accessors))]
+      (quasisyntax/loc stx (#%plain-app #,(relocate acc op) #,accum))))
+  (let ((ty  (type-of stx))
+        (obj (gen-alt-helper accessors)))
+    ;; we're calling the typechecker, but this is just a shortcut, we're
+    ;; still conceptually single pass (we're not iterating). we could get
+    ;; the same result by statically destructing the types.
+    (tc-expr/check obj ty)
+    obj))
+
+(define-syntax gen-pair-derived-expr
+  (syntax-parser
+    [(_ name:id (orig:id seq ...) ...)
+     (define/with-syntax (syntax-class-name ...) (generate-temporaries #'(orig ...)))
+     (define/with-syntax (lit-class-name ...) (generate-temporaries #'(orig ...)))
+     #'(begin
+         (begin
+           (define-literal-syntax-class lit-class-name (orig))
+           (define-syntax-class syntax-class-name
+             #:commit
+             (pattern (#%plain-app (~var op lit-class-name) arg)
+               #:with alt (gen-alt (list seq ...) #'op #'arg this-syntax)))) ...
+         (define-merged-syntax-class name (syntax-class-name ...)))]))
 
-(define-syntax-rule (gen-pair-derived-expr name (orig seq ...) ...)
-  (define-syntax-class name
-    #:commit
-    (pattern (#%plain-app (~literal orig) x)
-             #:with alt (gen-alt (list seq ...) this-syntax))
-    ...))
 (gen-pair-derived-expr pair-derived-expr
  (caar #'car #'car)
  (cadr #'car #'cdr)

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt

@@ -16,7 +16,9 @@
          mk-unsafe-tbl
          n-ary->binary n-ary-comp->binary
          opt-expr optimize
+         define-unsafe-syntax-class
          define-literal-syntax-class
+         define-merged-syntax-class
          syntax/loc/origin quasisyntax/loc/origin)
 
 ;; for tracking both origin and source location information
@@ -79,6 +81,22 @@
   #:attributes (opt)
   (pattern e:expr #:attr opt (delay ((optimize) #'e))))
 
+
+(define-syntax (define-unsafe-syntax-class stx)
+  (define-splicing-syntax-class spec
+    #:attributes (class-name (literals 1) unsafe-id)
+    (pattern (~seq class-name:id (literals:id ...) unsafe-id:id))
+    (pattern literal:id
+      #:with (literals ...) #'(literal)
+      #:with class-name (format-id #'literal "~a^" #'literal)
+      #:with unsafe-id (format-id #'literal "unsafe-~a" #'literal)))
+  (syntax-parse stx
+    [(_ :spec)
+     #'(begin
+         (define-literal-syntax-class literal (literals ...))
+         (define-syntax-class class-name
+           (pattern :literal #:with unsafe #'unsafe-id)))]))
+
 (define-syntax (define-literal-syntax-class stx)
   (define-splicing-syntax-class spec
     #:attributes (name (literals 1))
@@ -94,3 +112,8 @@
            #:literals (literals ...)
            (pattern (~and op (~or literals ...))
                     #:do [(add-disappeared-use (syntax-local-introduce #'op))]))))))
+
+(define-syntax-rule (define-merged-syntax-class name (syntax-classes ...))
+  (define-syntax-class name
+    #:auto-nested-attributes
+    (pattern (~var || syntax-classes)) ...))