diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/pair.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/pair.rkt index 8e082379..b8a9f8b6 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/pair.rkt +++ b/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) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt index 427a1c52..f87843a6 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt +++ b/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)) ...))