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

to-core moved and tweaked

Browse Source 
svn: r1332
This commit is contained in:
Matthew Flatt 2005-11-16 21:38:45 +00:00
parent e078b24e8a
commit 5f2299474d
2 changed files with 58 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/compiler/private/driver.ss
View File

@ -75,7 +75,7 @@
(require "../sig.ss"
"sig.ss"
"to-core.ss")
"../to-core.ss")
(provide driver@)
@ -252,6 +252,12 @@
;;----------------------------------------------------------------------
;; Misc utils
(define (simple-constant? s)
(or (identifier? s)
(number? (syntax-e s))
(empty? (syntax-e s))
(memq (syntax-e s) '(#t #f))))
;; takes a list of a-normalized expressions and analyzes them
;; returns the analyzed code, a list of local variable lists,
;; used variable lists, and captured variable lists
@ -685,7 +691,8 @@
#`'#,zodiac:global-lookup-id
#`'#,zodiac:global-assign-id
#`'#,zodiac:safe-vector-ref-id
#`'#,zodiac:global-prepare-id)])
#`'#,zodiac:global-prepare-id
simple-constant?)])
(list (zodiac:syntax->zodiac src)
bytecode magic-sym)))
(block-source s:file-block))])

87
collects/compiler/private/to-core.ss → collects/compiler/to-core.ss
View File

@ -11,13 +11,14 @@
;; `require-for-syntax', it's a timing issue. For `module', it's
;; because the transformation can only handle a single `module'
;; declaration.
(define (top-level-to-core stx lookup-stx set-stx safe-vector-ref-stx extract-stx)
(define (top-level-to-core stx lookup-stx set-stx safe-vector-ref-stx extract-stx simple-constant?)
(syntax-case stx (module begin)
[(module m lang (plain-module-begin decl ...))
(let-values ([(expr new-decls magic-sym)
(lift-sequence (flatten-decls (syntax->list #'(decl ...)))
lookup-stx set-stx safe-vector-ref-stx extract-stx
#t)])
#t
simple-constant?)])
(values (expand-syntax expr)
#`(module m lang (#%plain-module-begin #,@new-decls))
magic-sym))]
@ -25,12 +26,14 @@
(let-values ([(expr new-decls magic-sym)
(lift-sequence (flatten-decls (syntax->list #'(decl ...)))
lookup-stx set-stx safe-vector-ref-stx extract-stx
#f)])
#f
simple-constant?)])
(values (expand-syntax expr)
#`(begin #,@new-decls)
magic-sym))]
[else
(top-level-to-core #`(begin #,stx) lookup-stx set-stx safe-vector-ref-stx extract-stx)]))
(top-level-to-core #`(begin #,stx) lookup-stx set-stx safe-vector-ref-stx extract-stx
simple-constant?)]))
(define (flatten-decls l)
(apply append
@ -108,7 +111,13 @@
(generate-magic decls)
magic-sym)))
(define (lift-sequence decls lookup-stx set-stx safe-vector-ref-stx extract-stx in-module?)
(define (need-thunk? rhs)
(not (and (stx-pair? rhs)
(or (module-identifier=? #'lambda (stx-car rhs))
(module-identifier=? #'case-lambda (stx-car rhs))))))
(define (lift-sequence decls lookup-stx set-stx safe-vector-ref-stx extract-stx
in-module? simple-constant?)
(let ([ct-vars (make-vars)]
[rt-vars (make-vars)]
[compile-time (datum->syntax-object #f (gensym 'compile-time))]
@ -123,7 +132,8 @@
(let ([cvted (convert #'rhs #t
lookup-stx set-stx safe-vector-ref-stx
compile-time ct-vars
in-module?)])
in-module?
simple-constant?)])
(if (and (not in-module?)
(module-identifier=? #'def #'define-syntaxes))
;; Don't try to name macro procedures, because it
@ -134,29 +144,33 @@
(filter (lambda (x) (not (is-run-time? x))) decls))]
[rt-converted
(map (lambda (stx)
#`(lambda ()
#,(syntax-case stx (define-values provide require require-for-syntax require-for-template)
[(provide . _)
#'(void)]
[(require . _)
#'(void)]
[(require-for-syntax . _)
#'(void)]
[(require-for-template . _)
#'(void)]
[(define-values ids rhs)
#`(let-values ([ids
#,(convert #'rhs #f
lookup-stx set-stx safe-vector-ref-stx
run-time rt-vars
in-module?)])
(values . ids))]
[else
(convert stx #f
lookup-stx set-stx safe-vector-ref-stx
run-time rt-vars
in-module?)])))
(filter is-run-time? decls))]
(syntax-case stx (define-values provide require require-for-syntax require-for-template)
[(provide . _)
#'void]
[(require . _)
#'void]
[(require-for-syntax . _)
#'void]
[(require-for-template . _)
#'void]
[(define-values ids rhs)
(let ([converted (convert #'rhs #f
lookup-stx set-stx safe-vector-ref-stx
run-time rt-vars
in-module?
simple-constant?)])
(if (need-thunk? #'rhs)
#`(lambda () #,converted)
#`(let-values ([ids #,converted])
(values . ids))))]
[else
#`(lambda ()
#,(convert stx #f
lookup-stx set-stx safe-vector-ref-stx
run-time rt-vars
in-module?
simple-constant?))]))
(filter is-run-time? decls))]
[ct-rhs #`((let ([magic (car (cons '#,magic-sym 2))])
(if (symbol? magic)
(lambda (x) (vector
@ -241,8 +255,11 @@
[(require-for-template . _)
(car decls)]
[(define-values (id ...) rhs)
#`(define-values (id ...)
((vector-ref #,(if just-one-rt? rt-rhs run-time) #,rt-pos)))]
#`(define-values (id ...)
#,(let ([lookup #`(vector-ref #,(if just-one-rt? rt-rhs run-time) #,rt-pos)])
(if (need-thunk? #'rhs)
#`(#,lookup)
lookup)))]
[else
#`((vector-ref #,(if just-one-rt? rt-rhs run-time) #,rt-pos))])
(loop (cdr decls) ct-pos (add1 rt-pos)))]
@ -278,12 +295,6 @@
(datum->syntax-object #'here (cadr b) stx stx)]
[else #f])))
(define (simple-constant? s)
(or (identifier? s)
(number? (syntax-e s))
(empty? (syntax-e s))
(memq (syntax-e s) '(#t #f))))
(define (add-literal/pos stx li)
(let ([pos (lifted-info-counter li)])
(hash-table-put! (lifted-info-slot-map li) pos stx)
@ -314,7 +325,7 @@
(define (add-identifier stx li trans? lookup-stx id)
#`(#,lookup-stx #,id #,(add-identifier/pos stx li trans?)))
(define (convert stx trans? lookup-stx set-stx safe-vector-ref-stx id li in-module?)
(define (convert stx trans? lookup-stx set-stx safe-vector-ref-stx id li in-module? simple-constant?)
(define ((loop certs) stx)
(let ([loop (loop (apply-certs stx certs))])
(kernel-syntax-case stx trans?