Make stx.rkt cross-phase persistent.

This eliminates more than 70 linklet instance creations.
This commit is contained in:
Sam Tobin-Hochstadt 2018-05-11 15:48:58 -04:00
parent ce97087507
commit c6dd371ed6
6 changed files with 25 additions and 22 deletions

View File

@ -3,7 +3,7 @@
;; cond ;; cond
(module cond '#%kernel (module cond '#%kernel
(#%require (for-syntax "stx.rkt" "qq-and-or.rkt" '#%kernel)) (#%require (for-syntax "stx.rkt" "qq-and-or.rkt" '#%kernel "gen-temp.rkt"))
(define-syntaxes (=>) (define-syntaxes (=>)
(lambda (stx) (lambda (stx)

View File

@ -0,0 +1,18 @@
;;----------------------------------------------------------------------
;; stateful syntax support
(module gen-temp '#%kernel
(define-values (intro) #f)
(define-values (counter) 0)
(define-values (gen-temp-id)
;; Even though we gensym, using an introducer helps the
;; syntax system simplify renamings that can't apply
;; to other identifiers (when the generated identifier
;; is used as a binding id)
(lambda (pfx)
(if intro
(void)
(set! intro (make-syntax-introducer)))
(set! counter (add1 counter))
(intro (datum->syntax #f (string->uninterned-symbol (format "~a~a" pfx counter))))))
(#%provide gen-temp-id))

View File

@ -2,7 +2,7 @@
;; basic syntax utilities ;; basic syntax utilities
(module stx '#%kernel (module stx '#%kernel
(#%declare #:cross-phase-persistent)
;; These utilities facilitate operations on syntax objects. ;; These utilities facilitate operations on syntax objects.
;; A syntax object that represents a parenthesized sequence ;; A syntax object that represents a parenthesized sequence
;; can contain a mixture of cons cells and syntax objects, ;; can contain a mixture of cons cells and syntax objects,
@ -197,20 +197,6 @@
(loop s))]) (loop s))])
(values pre post (= m n))))) (values pre post (= m n)))))
(define-values (intro) #f)
(define-values (counter) 0)
(define-values (gen-temp-id)
;; Even though we gensym, using an introducer helps the
;; syntax system simplify renamings that can't apply
;; to other identifiers (when the generated identifier
;; is used as a binding id)
(lambda (pfx)
(if intro
(void)
(set! intro (make-syntax-introducer)))
(set! counter (add1 counter))
(intro (datum->syntax #f (string->uninterned-symbol (format "~a~a" pfx counter))))))
(#%provide identifier? stx-null? stx-null/#f stx-pair? stx-list? (#%provide identifier? stx-null? stx-null/#f stx-pair? stx-list?
stx-car stx-cdr stx->list stx-car stx-cdr stx->list
stx-vector? stx-vector-ref stx-vector? stx-vector-ref
@ -218,5 +204,4 @@
stx-prefab? stx-prefab?
stx-check/esc cons/#f append/#f stx-check/esc cons/#f append/#f
stx-rotate stx-rotate* stx-rotate stx-rotate*
split-stx-list split-stx-list))
gen-temp-id))

View File

@ -5,7 +5,7 @@
(#%require "stx.rkt" "small-scheme.rkt" '#%paramz '#%unsafe (#%require "stx.rkt" "small-scheme.rkt" '#%paramz '#%unsafe
"ellipses.rkt" "ellipses.rkt"
(for-syntax "stx.rkt" "small-scheme.rkt" (for-syntax "stx.rkt" "small-scheme.rkt"
"member.rkt" "sc.rkt" '#%kernel)) "gen-temp.rkt" "member.rkt" "sc.rkt" '#%kernel))
(-define interp-match (-define interp-match
(lambda (pat e literals immediate=?) (lambda (pat e literals immediate=?)

View File

@ -4,7 +4,7 @@
(module with-stx '#%kernel (module with-stx '#%kernel
(#%require "stx.rkt" "small-scheme.rkt" "stxcase.rkt" (#%require "stx.rkt" "small-scheme.rkt" "stxcase.rkt"
(for-syntax '#%kernel "stx.rkt" "stxcase.rkt" "stxloc.rkt" (for-syntax '#%kernel "stx.rkt" "stxcase.rkt" "stxloc.rkt"
"sc.rkt" "qq-and-or.rkt" "cond.rkt")) "gen-temp.rkt" "sc.rkt" "qq-and-or.rkt" "cond.rkt"))
(-define (with-syntax-fail stx) (-define (with-syntax-fail stx)
(raise-syntax-error (raise-syntax-error

View File

@ -1,5 +1,5 @@
(module repl '#%kernel (module repl '#%kernel
(#%declare #:cross-phase-persistent)
(#%provide read-eval-print-loop) (#%provide read-eval-print-loop)
(define-values (read-eval-print-loop) (define-values (read-eval-print-loop)
@ -30,4 +30,4 @@
(abort-current-continuation (default-continuation-prompt-tag)))))) (abort-current-continuation (default-continuation-prompt-tag))))))
(default-continuation-prompt-tag) (default-continuation-prompt-tag)
(lambda args (repl-loop))))]) (lambda args (repl-loop))))])
(repl-loop))))) (repl-loop)))))