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

map + syntax->list -> syntax-map

Browse Source
This commit is contained in:
Vincent St-Amour 2010-12-08 14:29:19 -05:00
parent b7588b0081
commit 33581fd67e
7 changed files with 59 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/typed-scheme/optimizer/box.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base
(require syntax/parse
(require syntax/parse unstable/syntax
racket/match
"../utils/utils.rkt"
(for-template scheme/base scheme/unsafe/ops)
@ -29,4 +29,4 @@
(pattern (#%plain-app op:box-op b:box-expr new:expr ...)
#:with opt
(begin (log-optimization "box" #'op)
#`(op.unsafe b.opt #,@(map (optimize) (syntax->list #'(new ...)))))))
#`(op.unsafe b.opt #,@(syntax-map (optimize) #'(new ...))))))

41
collects/typed-scheme/optimizer/float-complex.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base
(require syntax/parse syntax/id-table scheme/dict
(require syntax/parse syntax/id-table scheme/dict unstable/syntax
"../utils/utils.rkt" racket/unsafe/ops
(for-template scheme/base scheme/math racket/flonum scheme/unsafe/ops)
(types abbrev)
@ -71,8 +71,7 @@
(let ()
;; unlike addition, we simply can't skip real parts of imaginaries
(define (skip-0s l)
(let* ((l1 (map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list l)))
(let* ((l1 (syntax-map (lambda (x) (if (syntax->datum x) x #'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))))
@ -98,19 +97,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 (map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list #'(c1.real-binding c2.real-binding cs.real-binding ...))))
(li (map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list #'(c1.imag-binding c2.imag-binding cs.imag-binding ...)))))
#,@(let ((lr (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0))
#'(c1.real-binding c2.real-binding cs.real-binding ...)))
(li (syntax-map (lambda (x) (if (syntax->datum x) x #'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 (map (lambda (x) (unboxed-gensym "unboxed-real-"))
(syntax->list #'(cs.real-binding ...)))
[rs (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-real-"))
#'(cs.real-binding ...))
(list #'real-binding))]
[is (append (map (lambda (x) (unboxed-gensym "unboxed-imag-"))
(syntax->list #'(cs.imag-binding ...)))
[is (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
#'(cs.imag-binding ...))
(list #'imag-binding))]
[res '()])
(if (null? e1)
@ -142,10 +141,10 @@
#:when (or (isoftype? this-syntax -FloatComplex) (isoftype? this-syntax -Number))
#:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with reals (map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list #'(c1.real-binding c2.real-binding cs.real-binding ...)))
#:with imags (map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list #'(c1.imag-binding c2.imag-binding cs.imag-binding ...)))
#:with reals (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0))
#'(c1.real-binding c2.real-binding cs.real-binding ...))
#:with imags (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0))
#'(c1.imag-binding c2.imag-binding cs.imag-binding ...))
#:with (bindings ...)
(begin (log-optimization "unboxed binary float complex" #'op)
#`(c1.bindings ... c2.bindings ... cs.bindings ... ...
@ -155,14 +154,14 @@
[o2 (car (syntax->list #'imags))]
[e1 (cdr (syntax->list #'reals))]
[e2 (cdr (syntax->list #'imags))]
[rs (append (map (lambda (x) (unboxed-gensym "unboxed-real-"))
(syntax->list #'(cs.real-binding ...)))
[rs (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-real-"))
#'(cs.real-binding ...))
(list #'real-binding))]
[is (append (map (lambda (x) (unboxed-gensym "unboxed-imag-"))
(syntax->list #'(cs.imag-binding ...)))
[is (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
#'(cs.imag-binding ...))
(list #'imag-binding))]
[ds (map (lambda (x) (unboxed-gensym))
(syntax->list #'(c2.real-binding cs.real-binding ...)))]
[ds (syntax-map (lambda (x) (unboxed-gensym))
#'(c2.real-binding cs.real-binding ...))]
[res '()])
(if (null? e1)
(reverse res)

30
collects/typed-scheme/optimizer/optimizer.rkt
View File

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

4
collects/typed-scheme/optimizer/pair.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base
(require syntax/parse
(require syntax/parse unstable/syntax
racket/match
(for-template scheme/base scheme/unsafe/ops)
"../utils/utils.rkt"
@ -52,7 +52,7 @@
(pattern (#%plain-app op:mpair-op p:mpair-expr e:expr ...)
#:with opt
(begin (log-optimization "mutable pair" #'op)
#`(op.unsafe p.opt #,@(map (optimize) (syntax->list #'(e ...)))))))
#`(op.unsafe p.opt #,@(syntax-map (optimize) #'(e ...))))))
;; if the equivalent sequence of cars and cdrs is guaranteed not to fail,

4
collects/typed-scheme/optimizer/struct.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base
(require syntax/parse
(require syntax/parse unstable/syntax
(for-template scheme/base scheme/unsafe/ops)
"../utils/utils.rkt"
(types type-table)
@ -21,4 +21,4 @@
#`(unsafe-struct-ref #,((optimize) #'s) #,idx))
(begin (log-optimization "struct set" #'op)
#`(unsafe-struct-set! #,((optimize) #'s) #,idx
#,@(map (optimize) (syntax->list #'(v ...)))))))))
#,@(syntax-map (optimize) #'(v ...))))))))

32
collects/typed-scheme/optimizer/unboxed-let.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base
(require syntax/parse
(require syntax/parse unstable/syntax
scheme/list scheme/dict racket/match
"../utils/utils.rkt"
"../utils/tc-utils.rkt"
@ -62,7 +62,7 @@
(and (isoftype? (cadr p) -FloatComplex)
(could-be-unboxed-in? (car (syntax-e (car p)))
#'(begin body ...))))
(map syntax->list (syntax->list #'(clause ...)))))
(syntax-map syntax->list #'(clause ...))))
((function-candidates others)
;; extract function bindings that have float-complex arguments
;; we may be able to pass arguments unboxed
@ -142,7 +142,7 @@
(opt-candidates.bindings ... ...
opt-functions.res ...
opt-others.res ...)
#,@(map (optimize) (syntax->list #'(body ...)))))))
#,@(syntax-map (optimize) #'(body ...))))))
(define-splicing-syntax-class let-like-keyword
#:commit
@ -185,13 +185,13 @@
([ids e-rhs:expr] ...) e-body:expr ...)
#:with rebindings
(filter (lambda (x) x)
(map (syntax-parser
[((id) rhs)
#:when (and (identifier? #'rhs)
(free-identifier=? v #'rhs))
#'id]
[_ #f])
(syntax->list #'((ids e-rhs) ...))))
(syntax-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)))]
@ -288,15 +288,15 @@
#:when (syntax->datum #'unboxed-info)
;; partition of the arguments
#:with ((to-unbox ...) (boxed ...)) #'unboxed-info
#:with (real-params ...) (map (lambda (x) (unboxed-gensym "unboxed-real-"))
(syntax->list #'(to-unbox ...)))
#:with (imag-params ...) (map (lambda (x) (unboxed-gensym "unboxed-imag-"))
(syntax->list #'(to-unbox ...)))
#:with (real-params ...) (syntax-map (lambda (x) (unboxed-gensym "unboxed-real-"))
#'(to-unbox ...))
#:with (imag-params ...) (syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
#'(to-unbox ...))
#:with res
(begin
(log-optimization "fun -> unboxed fun" #'v)
;; add unboxed parameters to the unboxed vars table
(let ((to-unbox (map syntax->datum (syntax->list #'(to-unbox ...)))))
(let ((to-unbox (syntax-map syntax->datum #'(to-unbox ...))))
(let loop ((params (syntax->list #'params))
(i 0)
(real-parts (syntax->list #'(real-params ...)))
@ -308,7 +308,7 @@
;; be inserted when optimizing the body
#`((v) (#%plain-lambda
(real-params ... imag-params ... #,@(reverse boxed))
#,@(map (optimize) (syntax->list #'(body ...)))))]
#,@(syntax-map (optimize) #'(body ...))))]
[(memq i to-unbox) ; we unbox the current param, add to the table
(dict-set! unboxed-vars-table (car params)

4
collects/typed-scheme/optimizer/vector.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base
(require syntax/parse
(require syntax/parse unstable/syntax
racket/match
(for-template scheme/base racket/flonum scheme/unsafe/ops)
"../utils/utils.rkt"
@ -63,4 +63,4 @@
#:with opt
(begin (log-optimization "vector" #'op)
#`(op.unsafe v.opt #,((optimize) #'i)
#,@(map (optimize) (syntax->list #'(new ...)))))))
#,@(syntax-map (optimize) #'(new ...))))))