Move from syntax-map to stx-map.
original commit: 3e4a8acf70e96be87ec72ed8280bee8db3327386
This commit is contained in:
Eric Dobson
parent
7ed2a1540b
commit
fbea3dce95
|
|
@ -1,6 +1,6 @@
|
|||
#lang racket/base
|
||||
|
||||
(require syntax/parse unstable/syntax
|
||||
(require syntax/parse syntax/stx
|
||||
racket/match
|
||||
"../utils/utils.rkt"
|
||||
(for-template racket/base racket/unsafe/ops)
|
||||
|
|
@ -31,4 +31,4 @@
|
|||
#:with opt
|
||||
(begin (log-optimization "box" "Box check elimination." this-syntax)
|
||||
(add-disappeared-use #'op)
|
||||
#`(op.unsafe b.opt #,@(syntax-map (optimize) #'(new ...))))))
|
||||
#`(op.unsafe b.opt #,@(stx-map (optimize) #'(new ...))))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
#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
|
||||
(for-template racket/base racket/math racket/flonum racket/unsafe/ops)
|
||||
(utils tc-utils)
|
||||
|
|
@ -127,7 +128,7 @@
|
|||
(let ()
|
||||
;; unlike addition, we simply can't skip real parts of imaginaries
|
||||
(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
|
||||
(l2 (filter (lambda (x) (not (equal? (syntax->datum x) 0.0)))
|
||||
(cdr l1))))
|
||||
|
|
@ -168,19 +169,19 @@
|
|||
#`(c1.bindings ... c2.bindings ... cs.bindings ... ...
|
||||
;; we want to bind the intermediate results to reuse them
|
||||
;; the final results are bound to real-binding and imag-binding
|
||||
#,@(let ((lr (syntax-map get-part-or-0.0
|
||||
#'(c1.real-binding c2.real-binding cs.real-binding ...)))
|
||||
(li (syntax-map get-part-or-0.0
|
||||
#'(c1.imag-binding c2.imag-binding cs.imag-binding ...))))
|
||||
#,@(let ((lr (stx-map get-part-or-0.0
|
||||
#'(c1.real-binding c2.real-binding cs.real-binding ...)))
|
||||
(li (stx-map get-part-or-0.0
|
||||
#'(c1.imag-binding c2.imag-binding cs.imag-binding ...))))
|
||||
(let loop ([o1 (car lr)]
|
||||
[o2 (car li)]
|
||||
[e1 (cdr lr)]
|
||||
[e2 (cdr li)]
|
||||
[rs (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-real-"))
|
||||
#'(cs.real-binding ...))
|
||||
[rs (append (stx-map (lambda (x) (unboxed-gensym "unboxed-real-"))
|
||||
#'(cs.real-binding ...))
|
||||
(list #'real-binding))]
|
||||
[is (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
|
||||
#'(cs.imag-binding ...))
|
||||
[is (append (stx-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
|
||||
#'(cs.imag-binding ...))
|
||||
(list #'imag-binding))]
|
||||
[res '()])
|
||||
(if (null? e1)
|
||||
|
|
@ -212,10 +213,10 @@
|
|||
#:when (subtypeof? this-syntax -FloatComplex)
|
||||
#:with real-binding (unboxed-gensym "unboxed-real-")
|
||||
#:with imag-binding (unboxed-gensym "unboxed-imag-")
|
||||
#:with reals (syntax-map get-part-or-0.0
|
||||
#'(c1.real-binding c2.real-binding cs.real-binding ...))
|
||||
#:with imags (syntax-map get-part-or-0.0
|
||||
#'(c1.imag-binding c2.imag-binding cs.imag-binding ...))
|
||||
#:with reals (stx-map get-part-or-0.0
|
||||
#'(c1.real-binding c2.real-binding cs.real-binding ...))
|
||||
#:with imags (stx-map get-part-or-0.0
|
||||
#'(c1.imag-binding c2.imag-binding cs.imag-binding ...))
|
||||
#:with (bindings ...)
|
||||
(begin (log-optimization "unboxed binary float complex"
|
||||
complex-unboxing-opt-msg
|
||||
|
|
@ -228,11 +229,11 @@
|
|||
[b (car (syntax->list #'imags))]
|
||||
[e1 (cdr (syntax->list #'reals))]
|
||||
[e2 (cdr (syntax->list #'imags))]
|
||||
[rs (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-real-"))
|
||||
#'(cs.real-binding ...))
|
||||
[rs (append (stx-map (lambda (x) (unboxed-gensym "unboxed-real-"))
|
||||
#'(cs.real-binding ...))
|
||||
(list #'real-binding))]
|
||||
[is (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
|
||||
#'(cs.imag-binding ...))
|
||||
[is (append (stx-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
|
||||
#'(cs.imag-binding ...))
|
||||
(list #'imag-binding))]
|
||||
[res '()])
|
||||
(if (null? e1)
|
||||
|
|
@ -674,7 +675,7 @@
|
|||
(reset-unboxed-gensym)
|
||||
#`(let*-values (e.bindings ... ...)
|
||||
(#%plain-app #,opt-operator
|
||||
#,@(syntax-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.real-binding ...))
|
||||
#,@(stx-map get-part-or-0.0 #'(e.imag-binding ...))
|
||||
#,@(map (lambda (i) ((optimize) (get-arg i)))
|
||||
boxed)))])))) ; boxed params
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang racket/base
|
||||
|
||||
(require syntax/parse unstable/syntax
|
||||
(require syntax/parse syntax/stx
|
||||
(for-template racket/base)
|
||||
"../utils/utils.rkt"
|
||||
(optimizer utils logging)
|
||||
|
|
@ -31,11 +31,11 @@
|
|||
(syntax->list #'(args ...)))
|
||||
#:with opt
|
||||
(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
|
||||
;; hot loops.
|
||||
(pattern (#%plain-app op:id args ...)
|
||||
#:when (struct-constructor? #'op)
|
||||
#:with opt
|
||||
(begin (log-optimization-info "struct constructor" #'op)
|
||||
#`(op #,@(syntax-map (optimize) #'(args ...))))))
|
||||
#`(op #,@(stx-map (optimize) #'(args ...))))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang racket/base
|
||||
|
||||
(require syntax/parse unstable/syntax
|
||||
(require syntax/parse syntax/stx unstable/sequence
|
||||
racket/pretty
|
||||
(for-template racket/base)
|
||||
"../utils/utils.rkt"
|
||||
|
|
@ -51,36 +51,34 @@
|
|||
;; boring cases, just recur down
|
||||
(pattern ((~and op (~or (~literal #%plain-lambda) (~literal define-values)))
|
||||
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 ...] ...)
|
||||
;; optimize all the bodies
|
||||
#:with (opt-parts ...)
|
||||
(syntax-map (lambda (part)
|
||||
(let ((l (syntax->list part)))
|
||||
(cons (car l)
|
||||
(map (optimize) (cdr l)))))
|
||||
#'([formals e ...] ...))
|
||||
(for/list ([part (in-syntax #'([formals e ...] ...))])
|
||||
(let ((l (syntax->list part)))
|
||||
(cons (car l)
|
||||
(map (optimize) (cdr l)))))
|
||||
#:with opt (syntax/loc/origin this-syntax #'op (op opt-parts ...)))
|
||||
(pattern ((~and op (~or (~literal let-values) (~literal letrec-values)))
|
||||
([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
|
||||
(op ([ids opt-rhs] ...)
|
||||
#,@(syntax-map (optimize) #'(e-body ...)))))
|
||||
#,@(stx-map (optimize) #'(e-body ...)))))
|
||||
(pattern ((~and op letrec-syntaxes+values) stx-bindings
|
||||
([(ids ...) e-rhs:expr] ...)
|
||||
e-body:expr ...)
|
||||
;; optimize all the rhss
|
||||
#:with (opt-clauses ...)
|
||||
(syntax-map (lambda (clause)
|
||||
(let ((l (syntax->list clause)))
|
||||
(list (car l) ((optimize) (cadr l)))))
|
||||
#'([(ids ...) e-rhs] ...))
|
||||
(for/list ([clause (in-syntax #'([(ids ...) e-rhs] ...))])
|
||||
(let ((l (syntax->list clause)))
|
||||
(list (car l) ((optimize) (cadr l)))))
|
||||
#:with opt (quasisyntax/loc/origin this-syntax #'op
|
||||
(letrec-syntaxes+values
|
||||
stx-bindings
|
||||
(opt-clauses ...)
|
||||
#,@(syntax-map (optimize) #'(e-body ...)))))
|
||||
#,@(stx-map (optimize) #'(e-body ...)))))
|
||||
(pattern (kw:identifier expr ...)
|
||||
#:when
|
||||
(for/or ([k (in-list (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
|
||||
|
|
@ -88,7 +86,7 @@
|
|||
(free-identifier=? k #'kw))
|
||||
;; we don't want to optimize in the cases that don't match the #:when clause
|
||||
#:with opt (quasisyntax/loc/origin this-syntax #'kw
|
||||
(kw #,@(syntax-map (optimize) #'(expr ...)))))
|
||||
(kw #,@(stx-map (optimize) #'(expr ...)))))
|
||||
(pattern other:expr
|
||||
#:with opt #'other))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang racket/base
|
||||
|
||||
(require syntax/parse unstable/syntax
|
||||
(require syntax/parse syntax/stx
|
||||
racket/match
|
||||
(for-template racket/base racket/unsafe/ops racket/list)
|
||||
"../utils/utils.rkt"
|
||||
|
|
@ -66,7 +66,7 @@
|
|||
#:with opt
|
||||
(begin (log-pair-opt this-syntax)
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang racket/base
|
||||
|
||||
(require syntax/parse unstable/syntax
|
||||
(require syntax/parse syntax/stx unstable/syntax
|
||||
(for-template racket/base racket/unsafe/ops)
|
||||
"../utils/utils.rkt"
|
||||
(utils tc-utils)
|
||||
|
|
@ -25,4 +25,4 @@
|
|||
#`(unsafe-struct-ref #,((optimize) #'s) #,idx))
|
||||
(begin (log-optimization "struct set" struct-opt-msg this-syntax)
|
||||
#`(unsafe-struct-set! #,((optimize) #'s) #,idx
|
||||
#,@(syntax-map (optimize) #'(v ...))))))))
|
||||
#,@(stx-map (optimize) #'(v ...))))))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#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
|
||||
"../utils/utils.rkt"
|
||||
"../utils/tc-utils.rkt"
|
||||
|
|
@ -66,7 +66,7 @@
|
|||
(and (subtypeof? (cadr p) -FloatComplex)
|
||||
(could-be-unboxed-in? (car (syntax-e (car p)))
|
||||
#'(begin body ...))))
|
||||
(syntax-map syntax->list #'(clause ...))))
|
||||
(stx-map syntax->list #'(clause ...))))
|
||||
((function-candidates others)
|
||||
;; extract function bindings that have float-complex arguments
|
||||
;; we may be able to pass arguments unboxed
|
||||
|
|
@ -148,7 +148,7 @@
|
|||
(opt-functions.res ...
|
||||
opt-others.res ...
|
||||
opt-candidates.bindings ... ...)
|
||||
#,@(syntax-map (optimize) #'(body ...)))))))
|
||||
#,@(stx-map (optimize) #'(body ...)))))))
|
||||
|
||||
(define-splicing-syntax-class let-like-keyword
|
||||
#:commit
|
||||
|
|
@ -194,13 +194,13 @@
|
|||
([ids e-rhs:expr] ...) e-body:expr ...)
|
||||
#:with rebindings
|
||||
(filter (lambda (x) x)
|
||||
(syntax-map (syntax-parser
|
||||
[((id) rhs)
|
||||
#:when (and (identifier? #'rhs)
|
||||
(free-identifier=? v #'rhs))
|
||||
#'id]
|
||||
[_ #f])
|
||||
#'((ids e-rhs) ...)))
|
||||
(stx-map (syntax-parser
|
||||
[((id) rhs)
|
||||
#:when (and (identifier? #'rhs)
|
||||
(free-identifier=? v #'rhs))
|
||||
#'id]
|
||||
[_ #f])
|
||||
#'((ids e-rhs) ...)))
|
||||
(or (look-at #'(e-rhs ... e-body ...))
|
||||
(ormap (lambda (x) (could-be-unboxed-in? x exp))
|
||||
(syntax->list #'rebindings)))]
|
||||
|
|
@ -301,16 +301,14 @@
|
|||
;; partition of the arguments
|
||||
#:with ((to-unbox ...) (boxed ...)) #'unboxed-info
|
||||
#:with (real-params ...)
|
||||
(syntax-map (lambda (x) (unboxed-gensym "unboxed-real-"))
|
||||
#'(to-unbox ...))
|
||||
(stx-map (lambda (x) (unboxed-gensym "unboxed-real-")) #'(to-unbox ...))
|
||||
#:with (imag-params ...)
|
||||
(syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
|
||||
#'(to-unbox ...))
|
||||
(stx-map (lambda (x) (unboxed-gensym "unboxed-imag-")) #'(to-unbox ...))
|
||||
#:with res
|
||||
(begin
|
||||
(log-optimization "fun -> unboxed fun" arity-raising-opt-msg #'v)
|
||||
;; 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))
|
||||
(i 0)
|
||||
(real-parts (syntax->list #'(real-params ...)))
|
||||
|
|
@ -323,7 +321,7 @@
|
|||
#`((v) (#%plain-lambda
|
||||
(real-params ... imag-params ...
|
||||
#,@(reverse boxed))
|
||||
#,@(syntax-map (optimize) #'(body ...))))]
|
||||
#,@(stx-map (optimize) #'(body ...))))]
|
||||
|
||||
[(memq i to-unbox)
|
||||
;; we unbox the current param, add to the table
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang racket/base
|
||||
|
||||
(require syntax/parse unstable/syntax
|
||||
(require syntax/parse syntax/stx
|
||||
racket/match racket/flonum
|
||||
(for-template racket/base racket/flonum racket/unsafe/ops)
|
||||
"../utils/utils.rkt"
|
||||
|
|
@ -74,7 +74,7 @@
|
|||
(begin (log-optimization "vector" "Vector bounds checking elimination." this-syntax)
|
||||
(add-disappeared-use #'op)
|
||||
#`(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
|
||||
(pattern (#%plain-app op:vector-op v:expr i:fixnum-expr new:expr ...)
|
||||
|
|
@ -83,7 +83,7 @@
|
|||
"Partial bounds checking elimination."
|
||||
this-syntax)
|
||||
(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)])
|
||||
#`(let ([new-i #,((optimize) #'i)]
|
||||
[new-v #,((optimize) #'v)])
|
||||
|
|
@ -95,7 +95,7 @@
|
|||
one-sided
|
||||
#`(and (unsafe-fx>= new-i 0)
|
||||
#,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
|
||||
;; not an impersonator, can use unsafe-vector* ops
|
||||
(if #,(let ([one-sided #'(unsafe-fx< new-i (unsafe-vector-length new-v))])
|
||||
|
|
@ -103,7 +103,7 @@
|
|||
one-sided
|
||||
#`(and (unsafe-fx>= new-i 0)
|
||||
#,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))))))
|
||||
;; similarly for flvectors
|
||||
(pattern (#%plain-app op:flvector-op v:expr i:fixnum-expr new:expr ...)
|
||||
|
|
@ -112,7 +112,7 @@
|
|||
"Partial bounds checking elimination."
|
||||
this-syntax)
|
||||
(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)])
|
||||
#`(let ([new-i #,((optimize) #'i)]
|
||||
[new-v #,((optimize) #'v)])
|
||||
|
|
@ -121,5 +121,5 @@
|
|||
one-sided
|
||||
#`(and (unsafe-fx>= new-i 0)
|
||||
#,one-sided)))
|
||||
(op.unsafe new-v new-i #,@(syntax-map (optimize) #'(new ...)))
|
||||
(op.unsafe new-v new-i #,@(stx-map (optimize) #'(new ...)))
|
||||
#,safe-fallback))))))
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@
|
|||
syntax/free-vars
|
||||
(typecheck signatures tc-metafunctions tc-subst check-below)
|
||||
racket/match (contract-req)
|
||||
syntax/kerncase syntax/parse unstable/syntax
|
||||
syntax/kerncase syntax/parse syntax/stx
|
||||
(for-template racket/base (typecheck internal-forms)))
|
||||
|
||||
|
||||
|
|
@ -202,9 +202,7 @@
|
|||
(cond [(andmap (lambda (fv)
|
||||
(or (not (s:member fv letrec-bound-ids bound-identifier=?)) ; from outside
|
||||
(s:member fv transitively-safe-bindings bound-identifier=?)))
|
||||
(apply append
|
||||
(syntax-map (lambda (x) (free-vars x))
|
||||
clause-rhs)))
|
||||
(apply append (stx-map free-vars clause-rhs)))
|
||||
'transitively-safe]
|
||||
[else
|
||||
(syntax-parse clause-rhs #:literal-sets (kernel-literals)
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@
|
|||
|
||||
(require (for-syntax racket/base
|
||||
syntax/parse
|
||||
syntax/stx
|
||||
racket/syntax
|
||||
unstable/syntax
|
||||
typed-racket/utils/tc-utils)
|
||||
typed-racket/utils/tc-utils)
|
||||
|
||||
|
|
@ -32,7 +32,7 @@
|
|||
(typed/untyped-renamer #'typed-name #'untyped-name)))]))
|
||||
|
||||
(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)
|
||||
(syntax-parse stx #:literals (begin)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user