Move from syntax-map to stx-map.

This commit is contained in:
Eric Dobson 2013-05-25 00:55:11 -07:00
parent 4af6b6ffcf
commit 3e4a8acf70
10 changed files with 68 additions and 73 deletions

View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require syntax/parse unstable/syntax (require syntax/parse syntax/stx
racket/match racket/match
"../utils/utils.rkt" "../utils/utils.rkt"
(for-template racket/base racket/unsafe/ops) (for-template racket/base racket/unsafe/ops)
@ -31,4 +31,4 @@
#:with opt #:with opt
(begin (log-optimization "box" "Box check elimination." this-syntax) (begin (log-optimization "box" "Box check elimination." this-syntax)
(add-disappeared-use #'op) (add-disappeared-use #'op)
#`(op.unsafe b.opt #,@(syntax-map (optimize) #'(new ...)))))) #`(op.unsafe b.opt #,@(stx-map (optimize) #'(new ...))))))

View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require syntax/parse syntax/id-table racket/dict unstable/syntax racket/match (require syntax/parse syntax/stx syntax/id-table racket/dict
unstable/syntax racket/match
"../utils/utils.rkt" racket/unsafe/ops unstable/sequence "../utils/utils.rkt" racket/unsafe/ops unstable/sequence
(for-template racket/base racket/math racket/flonum racket/unsafe/ops) (for-template racket/base racket/math racket/flonum racket/unsafe/ops)
(utils tc-utils) (utils tc-utils)
@ -127,7 +128,7 @@
(let () (let ()
;; unlike addition, we simply can't skip real parts of imaginaries ;; unlike addition, we simply can't skip real parts of imaginaries
(define (skip-0s l) (define (skip-0s l)
(let* ((l1 (syntax-map get-part-or-0.0 l)) (let* ((l1 (stx-map get-part-or-0.0 l))
;; but we can skip all but the first 0 ;; but we can skip all but the first 0
(l2 (filter (lambda (x) (not (equal? (syntax->datum x) 0.0))) (l2 (filter (lambda (x) (not (equal? (syntax->datum x) 0.0)))
(cdr l1)))) (cdr l1))))
@ -168,18 +169,18 @@
#`(c1.bindings ... c2.bindings ... cs.bindings ... ... #`(c1.bindings ... c2.bindings ... cs.bindings ... ...
;; we want to bind the intermediate results to reuse them ;; we want to bind the intermediate results to reuse them
;; the final results are bound to real-binding and imag-binding ;; the final results are bound to real-binding and imag-binding
#,@(let ((lr (syntax-map get-part-or-0.0 #,@(let ((lr (stx-map get-part-or-0.0
#'(c1.real-binding c2.real-binding cs.real-binding ...))) #'(c1.real-binding c2.real-binding cs.real-binding ...)))
(li (syntax-map get-part-or-0.0 (li (stx-map get-part-or-0.0
#'(c1.imag-binding c2.imag-binding cs.imag-binding ...)))) #'(c1.imag-binding c2.imag-binding cs.imag-binding ...))))
(let loop ([o1 (car lr)] (let loop ([o1 (car lr)]
[o2 (car li)] [o2 (car li)]
[e1 (cdr lr)] [e1 (cdr lr)]
[e2 (cdr li)] [e2 (cdr li)]
[rs (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-real-")) [rs (append (stx-map (lambda (x) (unboxed-gensym "unboxed-real-"))
#'(cs.real-binding ...)) #'(cs.real-binding ...))
(list #'real-binding))] (list #'real-binding))]
[is (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-")) [is (append (stx-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
#'(cs.imag-binding ...)) #'(cs.imag-binding ...))
(list #'imag-binding))] (list #'imag-binding))]
[res '()]) [res '()])
@ -212,9 +213,9 @@
#:when (subtypeof? this-syntax -FloatComplex) #:when (subtypeof? this-syntax -FloatComplex)
#:with real-binding (unboxed-gensym "unboxed-real-") #:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-") #:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with reals (syntax-map get-part-or-0.0 #:with reals (stx-map get-part-or-0.0
#'(c1.real-binding c2.real-binding cs.real-binding ...)) #'(c1.real-binding c2.real-binding cs.real-binding ...))
#:with imags (syntax-map get-part-or-0.0 #:with imags (stx-map get-part-or-0.0
#'(c1.imag-binding c2.imag-binding cs.imag-binding ...)) #'(c1.imag-binding c2.imag-binding cs.imag-binding ...))
#:with (bindings ...) #:with (bindings ...)
(begin (log-optimization "unboxed binary float complex" (begin (log-optimization "unboxed binary float complex"
@ -228,10 +229,10 @@
[b (car (syntax->list #'imags))] [b (car (syntax->list #'imags))]
[e1 (cdr (syntax->list #'reals))] [e1 (cdr (syntax->list #'reals))]
[e2 (cdr (syntax->list #'imags))] [e2 (cdr (syntax->list #'imags))]
[rs (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-real-")) [rs (append (stx-map (lambda (x) (unboxed-gensym "unboxed-real-"))
#'(cs.real-binding ...)) #'(cs.real-binding ...))
(list #'real-binding))] (list #'real-binding))]
[is (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-")) [is (append (stx-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
#'(cs.imag-binding ...)) #'(cs.imag-binding ...))
(list #'imag-binding))] (list #'imag-binding))]
[res '()]) [res '()])
@ -674,7 +675,7 @@
(reset-unboxed-gensym) (reset-unboxed-gensym)
#`(let*-values (e.bindings ... ...) #`(let*-values (e.bindings ... ...)
(#%plain-app #,opt-operator (#%plain-app #,opt-operator
#,@(syntax-map get-part-or-0.0 #'(e.real-binding ...)) #,@(stx-map get-part-or-0.0 #'(e.real-binding ...))
#,@(syntax-map get-part-or-0.0 #'(e.imag-binding ...)) #,@(stx-map get-part-or-0.0 #'(e.imag-binding ...))
#,@(map (lambda (i) ((optimize) (get-arg i))) #,@(map (lambda (i) ((optimize) (get-arg i)))
boxed)))])))) ; boxed params boxed)))])))) ; boxed params

View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require syntax/parse unstable/syntax (require syntax/parse syntax/stx
(for-template racket/base) (for-template racket/base)
"../utils/utils.rkt" "../utils/utils.rkt"
(optimizer utils logging) (optimizer utils logging)
@ -31,11 +31,11 @@
(syntax->list #'(args ...))) (syntax->list #'(args ...)))
#:with opt #:with opt
(begin (log-optimization-info "hidden parameter" #'op) (begin (log-optimization-info "hidden parameter" #'op)
#`(op #,@(syntax-map (optimize) #'(args ...))))) #`(op #,@(stx-map (optimize) #'(args ...)))))
;; Log calls to struct constructors, so that OC can report those used in ;; Log calls to struct constructors, so that OC can report those used in
;; hot loops. ;; hot loops.
(pattern (#%plain-app op:id args ...) (pattern (#%plain-app op:id args ...)
#:when (struct-constructor? #'op) #:when (struct-constructor? #'op)
#:with opt #:with opt
(begin (log-optimization-info "struct constructor" #'op) (begin (log-optimization-info "struct constructor" #'op)
#`(op #,@(syntax-map (optimize) #'(args ...)))))) #`(op #,@(stx-map (optimize) #'(args ...))))))

View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require syntax/parse unstable/syntax (require syntax/parse syntax/stx unstable/sequence
racket/pretty racket/pretty
(for-template racket/base) (for-template racket/base)
"../utils/utils.rkt" "../utils/utils.rkt"
@ -51,36 +51,34 @@
;; boring cases, just recur down ;; boring cases, just recur down
(pattern ((~and op (~or (~literal #%plain-lambda) (~literal define-values))) (pattern ((~and op (~or (~literal #%plain-lambda) (~literal define-values)))
formals e:expr ...) formals e:expr ...)
#:with opt (quasisyntax/loc/origin this-syntax #'op (op formals #,@(syntax-map (optimize) #'(e ...))))) #:with opt (quasisyntax/loc/origin this-syntax #'op (op formals #,@(stx-map (optimize) #'(e ...)))))
(pattern ((~and op case-lambda) [formals e:expr ...] ...) (pattern ((~and op case-lambda) [formals e:expr ...] ...)
;; optimize all the bodies ;; optimize all the bodies
#:with (opt-parts ...) #:with (opt-parts ...)
(syntax-map (lambda (part) (for/list ([part (in-syntax #'([formals e ...] ...))])
(let ((l (syntax->list part))) (let ((l (syntax->list part)))
(cons (car l) (cons (car l)
(map (optimize) (cdr l))))) (map (optimize) (cdr l)))))
#'([formals e ...] ...))
#:with opt (syntax/loc/origin this-syntax #'op (op opt-parts ...))) #:with opt (syntax/loc/origin this-syntax #'op (op opt-parts ...)))
(pattern ((~and op (~or (~literal let-values) (~literal letrec-values))) (pattern ((~and op (~or (~literal let-values) (~literal letrec-values)))
([ids e-rhs:expr] ...) e-body:expr ...) ([ids e-rhs:expr] ...) e-body:expr ...)
#:with (opt-rhs ...) (syntax-map (optimize) #'(e-rhs ...)) #:with (opt-rhs ...) (stx-map (optimize) #'(e-rhs ...))
#:with opt (quasisyntax/loc/origin this-syntax #'op #:with opt (quasisyntax/loc/origin this-syntax #'op
(op ([ids opt-rhs] ...) (op ([ids opt-rhs] ...)
#,@(syntax-map (optimize) #'(e-body ...))))) #,@(stx-map (optimize) #'(e-body ...)))))
(pattern ((~and op letrec-syntaxes+values) stx-bindings (pattern ((~and op letrec-syntaxes+values) stx-bindings
([(ids ...) e-rhs:expr] ...) ([(ids ...) e-rhs:expr] ...)
e-body:expr ...) e-body:expr ...)
;; optimize all the rhss ;; optimize all the rhss
#:with (opt-clauses ...) #:with (opt-clauses ...)
(syntax-map (lambda (clause) (for/list ([clause (in-syntax #'([(ids ...) e-rhs] ...))])
(let ((l (syntax->list clause))) (let ((l (syntax->list clause)))
(list (car l) ((optimize) (cadr l))))) (list (car l) ((optimize) (cadr l)))))
#'([(ids ...) e-rhs] ...))
#:with opt (quasisyntax/loc/origin this-syntax #'op #:with opt (quasisyntax/loc/origin this-syntax #'op
(letrec-syntaxes+values (letrec-syntaxes+values
stx-bindings stx-bindings
(opt-clauses ...) (opt-clauses ...)
#,@(syntax-map (optimize) #'(e-body ...))))) #,@(stx-map (optimize) #'(e-body ...)))))
(pattern (kw:identifier expr ...) (pattern (kw:identifier expr ...)
#:when #:when
(for/or ([k (in-list (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression (for/or ([k (in-list (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
@ -88,7 +86,7 @@
(free-identifier=? k #'kw)) (free-identifier=? k #'kw))
;; we don't want to optimize in the cases that don't match the #:when clause ;; we don't want to optimize in the cases that don't match the #:when clause
#:with opt (quasisyntax/loc/origin this-syntax #'kw #:with opt (quasisyntax/loc/origin this-syntax #'kw
(kw #,@(syntax-map (optimize) #'(expr ...))))) (kw #,@(stx-map (optimize) #'(expr ...)))))
(pattern other:expr (pattern other:expr
#:with opt #'other)) #:with opt #'other))

View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require syntax/parse unstable/syntax (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)
"../utils/utils.rkt" "../utils/utils.rkt"
@ -66,7 +66,7 @@
#:with opt #:with opt
(begin (log-pair-opt this-syntax) (begin (log-pair-opt this-syntax)
(add-disappeared-use #'op) (add-disappeared-use #'op)
#`(op.unsafe #,@(syntax-map (optimize) #'(p e ...)))))) #`(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

View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require syntax/parse unstable/syntax (require syntax/parse syntax/stx unstable/syntax
(for-template racket/base racket/unsafe/ops) (for-template racket/base racket/unsafe/ops)
"../utils/utils.rkt" "../utils/utils.rkt"
(utils tc-utils) (utils tc-utils)
@ -25,4 +25,4 @@
#`(unsafe-struct-ref #,((optimize) #'s) #,idx)) #`(unsafe-struct-ref #,((optimize) #'s) #,idx))
(begin (log-optimization "struct set" struct-opt-msg this-syntax) (begin (log-optimization "struct set" struct-opt-msg this-syntax)
#`(unsafe-struct-set! #,((optimize) #'s) #,idx #`(unsafe-struct-set! #,((optimize) #'s) #,idx
#,@(syntax-map (optimize) #'(v ...)))))))) #,@(stx-map (optimize) #'(v ...))))))))

View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require syntax/parse unstable/syntax unstable/sequence (require syntax/parse syntax/stx unstable/syntax unstable/sequence
racket/list racket/dict racket/match racket/list racket/dict racket/match
"../utils/utils.rkt" "../utils/utils.rkt"
"../utils/tc-utils.rkt" "../utils/tc-utils.rkt"
@ -66,7 +66,7 @@
(and (subtypeof? (cadr p) -FloatComplex) (and (subtypeof? (cadr p) -FloatComplex)
(could-be-unboxed-in? (car (syntax-e (car p))) (could-be-unboxed-in? (car (syntax-e (car p)))
#'(begin body ...)))) #'(begin body ...))))
(syntax-map syntax->list #'(clause ...)))) (stx-map syntax->list #'(clause ...))))
((function-candidates others) ((function-candidates others)
;; extract function bindings that have float-complex arguments ;; extract function bindings that have float-complex arguments
;; we may be able to pass arguments unboxed ;; we may be able to pass arguments unboxed
@ -148,7 +148,7 @@
(opt-functions.res ... (opt-functions.res ...
opt-others.res ... opt-others.res ...
opt-candidates.bindings ... ...) opt-candidates.bindings ... ...)
#,@(syntax-map (optimize) #'(body ...))))))) #,@(stx-map (optimize) #'(body ...)))))))
(define-splicing-syntax-class let-like-keyword (define-splicing-syntax-class let-like-keyword
#:commit #:commit
@ -194,7 +194,7 @@
([ids e-rhs:expr] ...) e-body:expr ...) ([ids e-rhs:expr] ...) e-body:expr ...)
#:with rebindings #:with rebindings
(filter (lambda (x) x) (filter (lambda (x) x)
(syntax-map (syntax-parser (stx-map (syntax-parser
[((id) rhs) [((id) rhs)
#:when (and (identifier? #'rhs) #:when (and (identifier? #'rhs)
(free-identifier=? v #'rhs)) (free-identifier=? v #'rhs))
@ -301,16 +301,14 @@
;; partition of the arguments ;; partition of the arguments
#:with ((to-unbox ...) (boxed ...)) #'unboxed-info #:with ((to-unbox ...) (boxed ...)) #'unboxed-info
#:with (real-params ...) #:with (real-params ...)
(syntax-map (lambda (x) (unboxed-gensym "unboxed-real-")) (stx-map (lambda (x) (unboxed-gensym "unboxed-real-")) #'(to-unbox ...))
#'(to-unbox ...))
#:with (imag-params ...) #:with (imag-params ...)
(syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-")) (stx-map (lambda (x) (unboxed-gensym "unboxed-imag-")) #'(to-unbox ...))
#'(to-unbox ...))
#:with res #:with res
(begin (begin
(log-optimization "fun -> unboxed fun" arity-raising-opt-msg #'v) (log-optimization "fun -> unboxed fun" arity-raising-opt-msg #'v)
;; add unboxed parameters to the unboxed vars table ;; add unboxed parameters to the unboxed vars table
(let ((to-unbox (syntax-map syntax->datum #'(to-unbox ...)))) (let ((to-unbox (syntax->datum #'(to-unbox ...))))
(let loop ((params (syntax->list #'params)) (let loop ((params (syntax->list #'params))
(i 0) (i 0)
(real-parts (syntax->list #'(real-params ...))) (real-parts (syntax->list #'(real-params ...)))
@ -323,7 +321,7 @@
#`((v) (#%plain-lambda #`((v) (#%plain-lambda
(real-params ... imag-params ... (real-params ... imag-params ...
#,@(reverse boxed)) #,@(reverse boxed))
#,@(syntax-map (optimize) #'(body ...))))] #,@(stx-map (optimize) #'(body ...))))]
[(memq i to-unbox) [(memq i to-unbox)
;; we unbox the current param, add to the table ;; we unbox the current param, add to the table

View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require syntax/parse unstable/syntax (require syntax/parse syntax/stx
racket/match racket/flonum racket/match racket/flonum
(for-template racket/base racket/flonum racket/unsafe/ops) (for-template racket/base racket/flonum racket/unsafe/ops)
"../utils/utils.rkt" "../utils/utils.rkt"
@ -74,7 +74,7 @@
(begin (log-optimization "vector" "Vector bounds checking elimination." this-syntax) (begin (log-optimization "vector" "Vector bounds checking elimination." this-syntax)
(add-disappeared-use #'op) (add-disappeared-use #'op)
#`(op.unsafe v.opt #,((optimize) #'i) #`(op.unsafe v.opt #,((optimize) #'i)
#,@(syntax-map (optimize) #'(new ...))))) #,@(stx-map (optimize) #'(new ...)))))
;; we can do the bounds checking separately, to eliminate some of the checks ;; we can do the bounds checking separately, to eliminate some of the checks
(pattern (#%plain-app op:vector-op v:expr i:fixnum-expr new:expr ...) (pattern (#%plain-app op:vector-op v:expr i:fixnum-expr new:expr ...)
@ -83,7 +83,7 @@
"Partial bounds checking elimination." "Partial bounds checking elimination."
this-syntax) this-syntax)
(add-disappeared-use #'op) (add-disappeared-use #'op)
(let ([safe-fallback #`(op new-v new-i #,@(syntax-map (optimize) #'(new ...)))] (let ([safe-fallback #`(op new-v new-i #,@(stx-map (optimize) #'(new ...)))]
[i-known-nonneg? (subtypeof? #'i -NonNegFixnum)]) [i-known-nonneg? (subtypeof? #'i -NonNegFixnum)])
#`(let ([new-i #,((optimize) #'i)] #`(let ([new-i #,((optimize) #'i)]
[new-v #,((optimize) #'v)]) [new-v #,((optimize) #'v)])
@ -95,7 +95,7 @@
one-sided one-sided
#`(and (unsafe-fx>= new-i 0) #`(and (unsafe-fx>= new-i 0)
#,one-sided))) #,one-sided)))
(op.unsafe new-v new-i #,@(syntax-map (optimize) #'(new ...))) (op.unsafe new-v new-i #,@(stx-map (optimize) #'(new ...)))
#,safe-fallback) ; will error. to give the right error message #,safe-fallback) ; will error. to give the right error message
;; not an impersonator, can use unsafe-vector* ops ;; not an impersonator, can use unsafe-vector* ops
(if #,(let ([one-sided #'(unsafe-fx< new-i (unsafe-vector-length new-v))]) (if #,(let ([one-sided #'(unsafe-fx< new-i (unsafe-vector-length new-v))])
@ -103,7 +103,7 @@
one-sided one-sided
#`(and (unsafe-fx>= new-i 0) #`(and (unsafe-fx>= new-i 0)
#,one-sided))) #,one-sided)))
(op.unsafe-no-impersonator new-v new-i #,@(syntax-map (optimize) #'(new ...))) (op.unsafe-no-impersonator new-v new-i #,@(stx-map (optimize) #'(new ...)))
#,safe-fallback)))))) #,safe-fallback))))))
;; similarly for flvectors ;; similarly for flvectors
(pattern (#%plain-app op:flvector-op v:expr i:fixnum-expr new:expr ...) (pattern (#%plain-app op:flvector-op v:expr i:fixnum-expr new:expr ...)
@ -112,7 +112,7 @@
"Partial bounds checking elimination." "Partial bounds checking elimination."
this-syntax) this-syntax)
(add-disappeared-use #'op) (add-disappeared-use #'op)
(let ([safe-fallback #`(op new-v new-i #,@(syntax-map (optimize) #'(new ...)))] (let ([safe-fallback #`(op new-v new-i #,@(stx-map (optimize) #'(new ...)))]
[i-known-nonneg? (subtypeof? #'i -NonNegFixnum)]) [i-known-nonneg? (subtypeof? #'i -NonNegFixnum)])
#`(let ([new-i #,((optimize) #'i)] #`(let ([new-i #,((optimize) #'i)]
[new-v #,((optimize) #'v)]) [new-v #,((optimize) #'v)])
@ -121,5 +121,5 @@
one-sided one-sided
#`(and (unsafe-fx>= new-i 0) #`(and (unsafe-fx>= new-i 0)
#,one-sided))) #,one-sided)))
(op.unsafe new-v new-i #,@(syntax-map (optimize) #'(new ...))) (op.unsafe new-v new-i #,@(stx-map (optimize) #'(new ...)))
#,safe-fallback)))))) #,safe-fallback))))))

View File

@ -10,7 +10,7 @@
syntax/free-vars syntax/free-vars
(typecheck signatures tc-metafunctions tc-subst check-below) (typecheck signatures tc-metafunctions tc-subst check-below)
racket/match (contract-req) racket/match (contract-req)
syntax/kerncase syntax/parse unstable/syntax syntax/kerncase syntax/parse syntax/stx
(for-template racket/base (typecheck internal-forms))) (for-template racket/base (typecheck internal-forms)))
@ -202,9 +202,7 @@
(cond [(andmap (lambda (fv) (cond [(andmap (lambda (fv)
(or (not (s:member fv letrec-bound-ids bound-identifier=?)) ; from outside (or (not (s:member fv letrec-bound-ids bound-identifier=?)) ; from outside
(s:member fv transitively-safe-bindings bound-identifier=?))) (s:member fv transitively-safe-bindings bound-identifier=?)))
(apply append (apply append (stx-map free-vars clause-rhs)))
(syntax-map (lambda (x) (free-vars x))
clause-rhs)))
'transitively-safe] 'transitively-safe]
[else [else
(syntax-parse clause-rhs #:literal-sets (kernel-literals) (syntax-parse clause-rhs #:literal-sets (kernel-literals)

View File

@ -2,8 +2,8 @@
(require (for-syntax racket/base (require (for-syntax racket/base
syntax/parse syntax/parse
syntax/stx
racket/syntax racket/syntax
unstable/syntax
typed-racket/utils/tc-utils) typed-racket/utils/tc-utils)
typed-racket/utils/tc-utils) typed-racket/utils/tc-utils)
@ -32,7 +32,7 @@
(typed/untyped-renamer #'typed-name #'untyped-name)))])) (typed/untyped-renamer #'typed-name #'untyped-name)))]))
(define-for-syntax (freshen ids) (define-for-syntax (freshen ids)
(syntax-map (lambda (id) ((make-syntax-introducer) id)) ids)) (stx-map (lambda (id) ((make-syntax-introducer) id)) ids))
(define-syntax (require/untyped-contract stx) (define-syntax (require/untyped-contract stx)
(syntax-parse stx #:literals (begin) (syntax-parse stx #:literals (begin)