431 lines
17 KiB
Racket
431 lines
17 KiB
Racket
(module to-core scheme/base
|
|
(require syntax/kerncase
|
|
syntax/stx
|
|
mzlib/list
|
|
syntax/boundmap
|
|
(for-syntax scheme/base))
|
|
|
|
(provide top-level-to-core)
|
|
|
|
;; `module', `require', and `require-for-syntax' declarations must
|
|
;; not be embedded in a `begin' sequence. For `require' and
|
|
;; `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
|
|
simple-constant? stop-properties)
|
|
(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
|
|
simple-constant? stop-properties)])
|
|
(values (expand-syntax expr)
|
|
#`(module m lang (#%plain-module-begin #,@new-decls))
|
|
magic-sym))]
|
|
[(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
|
|
#f
|
|
simple-constant? stop-properties)])
|
|
(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
|
|
simple-constant? stop-properties)]))
|
|
|
|
(define (flatten-decls l)
|
|
(apply append
|
|
(map (lambda (stx)
|
|
(syntax-case stx (begin)
|
|
[(begin . e)
|
|
(flatten-decls (syntax->list #'e))]
|
|
[else (list stx)]))
|
|
l)))
|
|
|
|
(define-struct lifted-info ([counter #:mutable] id-map slot-map))
|
|
|
|
(define (make-vars)
|
|
(make-lifted-info
|
|
0
|
|
(make-module-identifier-mapping)
|
|
(make-hash)))
|
|
|
|
(define (is-id-ref? v)
|
|
(or (identifier? v)
|
|
(and (stx-pair? v)
|
|
(identifier? (stx-car v))
|
|
(free-identifier=? #'#%top (stx-car v)))))
|
|
|
|
(define (vars-sequence li)
|
|
(let loop ([i 0])
|
|
(if (= i (lifted-info-counter li))
|
|
null
|
|
(cons (let ([v (hash-ref (lifted-info-slot-map li) i)])
|
|
(if (is-id-ref? v)
|
|
#`(#%variable-reference #,v)
|
|
v))
|
|
(loop (add1 i))))))
|
|
|
|
(define (extract-vars li vec-id extract-stx)
|
|
(let loop ([i 0])
|
|
(if (= i (lifted-info-counter li))
|
|
null
|
|
(let ([v (hash-ref (lifted-info-slot-map li) i)])
|
|
(if (is-id-ref? v)
|
|
(cons #`(#,extract-stx #,vec-id #,i)
|
|
(loop (add1 i)))
|
|
(loop (add1 i)))))))
|
|
|
|
(define (is-run-time? stx)
|
|
(not (and (stx-pair? stx)
|
|
(or (free-identifier=? #'define-syntaxes (stx-car stx))
|
|
(free-identifier=? #'define-values-for-syntax (stx-car stx))))))
|
|
|
|
(define (has-symbol? decl magic-sym table)
|
|
(cond
|
|
[(hash-ref table decl (lambda () #f))
|
|
;; cycle/graph
|
|
#f]
|
|
[else
|
|
(hash-set! table decl #t)
|
|
(cond
|
|
[(eq? magic-sym decl)
|
|
#t]
|
|
[(pair? decl)
|
|
(or (has-symbol? (car decl) magic-sym table)
|
|
(has-symbol? (cdr decl) magic-sym table))]
|
|
[(vector? decl)
|
|
(has-symbol? (vector->list decl) magic-sym table)]
|
|
[(box? decl)
|
|
(has-symbol? (unbox decl) magic-sym table)]
|
|
[else
|
|
#f])]))
|
|
|
|
(define (generate-magic decls)
|
|
(let ([magic-sym (string->symbol (format "magic~a~a"
|
|
(current-seconds)
|
|
(current-milliseconds)))])
|
|
(if (has-symbol? (map syntax->datum decls) magic-sym (make-hasheq))
|
|
(generate-magic decls)
|
|
magic-sym)))
|
|
|
|
(define (need-thunk? rhs)
|
|
(not (and (stx-pair? rhs)
|
|
(or (free-identifier=? #'lambda (stx-car rhs))
|
|
(free-identifier=? #'case-lambda (stx-car rhs))))))
|
|
|
|
(define (lift-sequence decls lookup-stx set-stx safe-vector-ref-stx extract-stx
|
|
in-module? simple-constant? stop-properties)
|
|
(let ([ct-vars (make-vars)]
|
|
[rt-vars (make-vars)]
|
|
[compile-time (datum->syntax #f (gensym 'compile-time))]
|
|
[run-time (datum->syntax #f (gensym 'run-time))]
|
|
[magic-sym (generate-magic decls)]
|
|
[magic-indirect (gensym)])
|
|
(let ([ct-converted
|
|
(map (lambda (stx)
|
|
#`(lambda ()
|
|
#,(syntax-case stx ()
|
|
[(def ids rhs)
|
|
(let ([cvted (convert #'rhs #t
|
|
lookup-stx set-stx safe-vector-ref-stx
|
|
compile-time ct-vars
|
|
in-module?
|
|
simple-constant? stop-properties)])
|
|
(if (and (not in-module?)
|
|
(free-identifier=? #'def #'define-syntaxes))
|
|
;; Don't try to name macro procedures, because it
|
|
;; inteferes with the 0-values hack at the top level
|
|
cvted
|
|
#`(let-values ([ids #,cvted])
|
|
(#%plain-app values . ids))))])))
|
|
(filter (lambda (x) (not (is-run-time? x))) decls))]
|
|
[rt-converted
|
|
(map (lambda (stx)
|
|
(syntax-case stx (define-values
|
|
#%provide
|
|
#%require)
|
|
[(#%provide . _)
|
|
#'void]
|
|
[(#%require . _)
|
|
#'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? stop-properties)])
|
|
(if (need-thunk? #'rhs)
|
|
#`(lambda () #,converted)
|
|
#`(let-values ([ids #,converted])
|
|
(#%plain-app values . ids))))]
|
|
[else
|
|
#`(lambda ()
|
|
#,(convert stx #f
|
|
lookup-stx set-stx safe-vector-ref-stx
|
|
run-time rt-vars
|
|
in-module?
|
|
simple-constant? stop-properties))]))
|
|
(filter is-run-time? decls))]
|
|
[ct-rhs #`(#%plain-app
|
|
(let-values ([(magic) (#%plain-app car (#%plain-app cons '#,magic-sym 2))])
|
|
(if (#%plain-app symbol? magic)
|
|
(#%plain-lambda (x)
|
|
(#%plain-app
|
|
vector
|
|
#,@(map (lambda (stx)
|
|
(syntax-case stx ()
|
|
[(def (id) . _)
|
|
#'void]
|
|
[(def (id ...) . _)
|
|
(with-syntax ([(v ...) (map (lambda (x) #f)
|
|
(syntax->list #'(id ...)))])
|
|
|
|
#`(#%plain-lambda () (#%plain-app values v ...)))]))
|
|
(filter (lambda (x) (not (is-run-time? x))) decls))))
|
|
(#%plain-app car magic)))
|
|
(#%plain-app vector #,@(vars-sequence ct-vars)))]
|
|
[rt-rhs #`(#%plain-app (#%plain-app cdr '#,magic-sym)
|
|
(#%plain-app vector #,@(vars-sequence rt-vars)))]
|
|
[just-one-ct? (>= 1 (apply +
|
|
(map (lambda (decl)
|
|
(syntax-case decl (define-syntaxes define-values-for-syntax)
|
|
[(define-values-for-syntax . _) 1]
|
|
[(define-syntaxes . _) 1]
|
|
[_else 0]))
|
|
decls)))]
|
|
[just-one-rt? (>= 1 (apply +
|
|
(map (lambda (decl)
|
|
(syntax-case decl (define-values #%provide #%require
|
|
define-syntaxes define-values-for-syntax)
|
|
[(#%provide . _) 0]
|
|
[(#%require . _) 0]
|
|
[(define-values-for-syntax . _) 0]
|
|
[(define-syntaxes . _) 0]
|
|
[_else 1]))
|
|
decls)))])
|
|
(values
|
|
#`(#%plain-app
|
|
cons (#%plain-lambda (#,compile-time)
|
|
#,@(extract-vars ct-vars compile-time extract-stx)
|
|
(#%plain-app vector #,@ct-converted))
|
|
(#%plain-lambda (#,run-time)
|
|
#,@(extract-vars rt-vars run-time extract-stx)
|
|
(#%plain-app vector #,@rt-converted)))
|
|
#`(;; Lift require and require-for-syntaxes to the front, so they're ready for
|
|
;; variable references
|
|
#,@(filter (lambda (decl)
|
|
(syntax-case decl (#%require)
|
|
[(#%require . _) #t]
|
|
[_else #f]))
|
|
decls)
|
|
;; Lift define-for-values binding to front, so they can be referenced
|
|
;; in compile-time definition
|
|
#,@(let ([ids (apply
|
|
append
|
|
(map (lambda (stx)
|
|
(syntax-case stx (define-values-for-syntax)
|
|
[(define-values-for-syntax ids . _)
|
|
(syntax->list #'ids)]
|
|
[_else null]))
|
|
decls))])
|
|
(if (null? ids)
|
|
null
|
|
#`((define-values-for-syntax #,ids
|
|
(values #,@(map (lambda (x) #'#f) ids))))))
|
|
#,@(if just-one-ct?
|
|
null
|
|
#`((define-values-for-syntax (#,compile-time) #,ct-rhs)))
|
|
#,@(if just-one-rt?
|
|
null
|
|
#`((define-values (#,run-time) #,rt-rhs)))
|
|
#,@(let loop ([decls decls][ct-pos 0][rt-pos 0])
|
|
(cond
|
|
[(null? decls) null]
|
|
[(is-run-time? (car decls))
|
|
(cons (syntax-case (car decls) (define-values #%provide #%require)
|
|
[(#%provide . _)
|
|
(car decls)]
|
|
[(#%require . _)
|
|
#'(#%plain-app void)]
|
|
[(define-values (id ...) rhs)
|
|
#`(define-values (id ...)
|
|
#,(let ([lookup #`(#%plain-app vector-ref #,(if just-one-rt? rt-rhs run-time) #,rt-pos)])
|
|
(if (need-thunk? #'rhs)
|
|
#`(#%plain-app #,lookup)
|
|
lookup)))]
|
|
[else
|
|
#`(#%plain-app (#%plain-app vector-ref #,(if just-one-rt? rt-rhs run-time) #,rt-pos))])
|
|
(loop (cdr decls) ct-pos (add1 rt-pos)))]
|
|
[else
|
|
(cons (syntax-case (car decls) (define-syntaxes define-values-for-syntax)
|
|
[(define-syntaxes (id ...) . rhs)
|
|
#`(define-syntaxes (id ...)
|
|
(#%plain-app (#%plain-app vector-ref #,(if just-one-ct? ct-rhs compile-time) #,ct-pos)))]
|
|
[(define-values-for-syntax (id ...) . rhs)
|
|
#`(define-values-for-syntax ()
|
|
(begin
|
|
(set!-values (id ...)
|
|
(#%plain-app
|
|
(#%plain-app vector-ref #,(if just-one-ct? ct-rhs compile-time)
|
|
#,ct-pos)))
|
|
(#%plain-app values)))])
|
|
(loop (cdr decls) (add1 ct-pos) rt-pos))])))
|
|
magic-sym))))
|
|
|
|
(define (local-identifier? stx trans?)
|
|
(eq? 'lexical ((if trans?
|
|
identifier-transformer-binding
|
|
identifier-binding)
|
|
stx)))
|
|
|
|
(define (simple-identifier stx trans?)
|
|
(let ([b ((if trans?
|
|
identifier-transformer-binding
|
|
identifier-binding)
|
|
stx)])
|
|
(cond
|
|
[(eq? b 'lexical) stx]
|
|
[(and (pair? b)
|
|
(eq? '#%kernel (car b)))
|
|
;; Generate a syntax object that has the right run-time binding:
|
|
(datum->syntax #'here (cadr b) stx stx)]
|
|
[else #f])))
|
|
|
|
(define (add-literal/pos stx li)
|
|
(let ([pos (lifted-info-counter li)])
|
|
(hash-set! (lifted-info-slot-map li) pos stx)
|
|
(set-lifted-info-counter! li (add1 pos))
|
|
pos))
|
|
|
|
(define (add-literal stx li safe-vector-ref-stx id)
|
|
#`(#,safe-vector-ref-stx #,id #,(add-literal/pos stx li)))
|
|
|
|
(define (add-identifier/pos stx li trans?)
|
|
(if (identifier? stx)
|
|
;; id :
|
|
(or (module-identifier-mapping-get (lifted-info-id-map li)
|
|
stx
|
|
(lambda () #f))
|
|
(let ([pos (add-literal/pos (if (not ((if trans?
|
|
identifier-transformer-binding
|
|
identifier-binding)
|
|
stx))
|
|
#`(#%top . #,stx)
|
|
stx)
|
|
li)])
|
|
(module-identifier-mapping-put! (lifted-info-id-map li) stx pos)
|
|
pos))
|
|
;; (#%top . id) :
|
|
(add-literal/pos stx li)))
|
|
|
|
(define (add-identifier stx li trans? lookup-stx id)
|
|
#`(#,lookup-stx #,id #,(add-identifier/pos stx li trans?)))
|
|
|
|
(define-syntax quasisyntax/loc+props
|
|
(syntax-rules ()
|
|
[(_ stx e) (let ([old-s stx]
|
|
[new-s (quasisyntax e)])
|
|
(syntax-recertify
|
|
(datum->syntax new-s
|
|
(syntax-e new-s)
|
|
old-s
|
|
old-s)
|
|
new-s
|
|
code-insp
|
|
#f))]))
|
|
(define code-insp (current-code-inspector))
|
|
|
|
(define (convert stx trans? lookup-stx set-stx safe-vector-ref-stx id li in-module?
|
|
simple-constant? stop-properties)
|
|
(define ((loop certs) stx)
|
|
(let ([loop (loop (apply-certs stx certs))])
|
|
(if (ormap (lambda (prop)
|
|
(syntax-property stx prop))
|
|
stop-properties)
|
|
stx
|
|
(kernel-syntax-case stx trans?
|
|
[_
|
|
(identifier? stx)
|
|
(or (simple-identifier stx trans?)
|
|
(add-identifier (apply-certs certs stx) li trans? lookup-stx id))]
|
|
[(#%provide . _)
|
|
stx]
|
|
[(#%plain-lambda formals e ...)
|
|
(quasisyntax/loc+props
|
|
stx
|
|
(#%plain-lambda formals #,@(map loop (syntax->list #'(e ...)))))]
|
|
[(case-lambda [formals e ...] ...)
|
|
(with-syntax ([((e ...) ...)
|
|
(map (lambda (l)
|
|
(map loop (syntax->list l)))
|
|
(syntax->list #'((e ...) ...)))])
|
|
(quasisyntax/loc+props
|
|
stx
|
|
(case-lambda [formals e ...] ...)))]
|
|
[(let-values ([(id ...) rhs] ...) e ...)
|
|
(with-syntax ([(rhs ...)
|
|
(map loop (syntax->list #'(rhs ...)))])
|
|
(quasisyntax/loc+props
|
|
stx
|
|
(let-values ([(id ...) rhs] ...) #,@(map loop (syntax->list #'(e ...))))))]
|
|
[(letrec-values ([(id ...) rhs] ...) e ...)
|
|
(with-syntax ([(rhs ...)
|
|
(map loop (syntax->list #'(rhs ...)))])
|
|
(quasisyntax/loc+props
|
|
stx
|
|
(letrec-values ([(id ...) rhs] ...) #,@(map loop (syntax->list #'(e ...))))))]
|
|
[(quote e)
|
|
(if (simple-constant? #'e)
|
|
#'(quote e)
|
|
(add-literal stx li safe-vector-ref-stx id))]
|
|
[(quote-syntax e)
|
|
(add-literal stx li safe-vector-ref-stx id)]
|
|
[(#%top . tid)
|
|
(let ([target (let ([b ((if trans?
|
|
identifier-transformer-binding
|
|
identifier-binding)
|
|
#'tid)])
|
|
(if (or (eq? b 'lexical)
|
|
(and (not in-module?)
|
|
b))
|
|
#`(#%top . tid)
|
|
#'tid))])
|
|
(add-identifier (apply-certs certs target) li trans? lookup-stx id))]
|
|
[(set! x e)
|
|
(if (local-identifier? #'x trans?)
|
|
(quasisyntax/loc+props stx (set! x #,(loop #'e)))
|
|
(quasisyntax/loc+props
|
|
stx
|
|
(#,set-stx #,id #,(add-identifier/pos (apply-certs certs #'x) li trans?) #,(loop #'e))))]
|
|
[(#%variable-reference e)
|
|
(add-literal stx li safe-vector-ref-stx id)]
|
|
[(if e ...)
|
|
(quasisyntax/loc+props
|
|
stx
|
|
(if #,@(map loop (syntax->list #'(e ...)))))]
|
|
[(begin e ...)
|
|
(quasisyntax/loc+props
|
|
stx
|
|
(begin #,@(map loop (syntax->list #'(e ...)))))]
|
|
[(begin0 e ...)
|
|
(quasisyntax/loc+props
|
|
stx
|
|
(begin0 #,@(map loop (syntax->list #'(e ...)))))]
|
|
[(with-continuation-mark e ...)
|
|
(quasisyntax/loc+props
|
|
stx
|
|
(with-continuation-mark #,@(map loop (syntax->list #'(e ...)))))]
|
|
[(#%plain-app e ...)
|
|
(quasisyntax/loc+props
|
|
stx
|
|
(#%plain-app #,@(map loop (syntax->list #'(e ...)))))]))))
|
|
((loop #'certs) stx))
|
|
|
|
(define (apply-certs from to)
|
|
(syntax-recertify to from (current-code-inspector) #f)))
|