suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Make pair-opt cleaner.

Browse Source
This commit is contained in:
Eric Dobson 2013-08-30 09:50:18 -07:00
parent fbfd09e804
commit fe35cc096c
2 changed files with 77 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

110
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/pair.rkt
View File

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

23
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt
View File

@ -16,7 +16,9 @@
mk-unsafe-tbl mk-unsafe-tbl
n-ary->binary n-ary-comp->binary n-ary->binary n-ary-comp->binary
opt-expr optimize opt-expr optimize
define-unsafe-syntax-class
define-literal-syntax-class define-literal-syntax-class
define-merged-syntax-class
syntax/loc/origin quasisyntax/loc/origin) syntax/loc/origin quasisyntax/loc/origin)
;; for tracking both origin and source location information ;; for tracking both origin and source location information
@ -79,6 +81,22 @@
#:attributes (opt) #:attributes (opt)
(pattern e:expr #:attr opt (delay ((optimize) #'e)))) (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-syntax (define-literal-syntax-class stx)
(define-splicing-syntax-class spec (define-splicing-syntax-class spec
#:attributes (name (literals 1)) #:attributes (name (literals 1))
@ -94,3 +112,8 @@
#:literals (literals ...) #:literals (literals ...)
(pattern (~and op (~or literals ...)) (pattern (~and op (~or literals ...))
#:do [(add-disappeared-use (syntax-local-introduce #'op))])))))) #: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)) ...))