From 8a02ff54ac8aa3cb326cafa8de33cde51d326203 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 19 Sep 2012 02:52:10 -0400 Subject: [PATCH] syntax/parse/experimental/template: improve prop handling & syntax checks Separate parameters for props to serialize and those to transfer. Make syntax?/list? checks on attributes explicit. Also add continuation barrier around metafunction application. --- .../parse/experimental/private/substitute.rkt | 120 +++++++++---- .../syntax/parse/experimental/template.rkt | 158 +++++++++++------- 2 files changed, 186 insertions(+), 92 deletions(-) diff --git a/collects/syntax/parse/experimental/private/substitute.rkt b/collects/syntax/parse/experimental/private/substitute.rkt index 119be6d5d3..92ae21fedc 100644 --- a/collects/syntax/parse/experimental/private/substitute.rkt +++ b/collects/syntax/parse/experimental/private/substitute.rkt @@ -1,8 +1,7 @@ #lang racket/base (require syntax/parse/private/minimatch racket/private/stx) ;; syntax/stx -(provide translate - error/not-stx) +(provide translate) #| ;; Doesn't seem to make much difference. @@ -18,13 +17,13 @@ #| A Guide (G) is one of: - '_ - - positive-exact-integer ;; represents depth=0 pvar ref or metafun ref - - negative-exact-integer ;; represents depth>0 pvar ref (within ellipsis) + - VarRef ;; no syntax check + - (vector 'check VarRef) ;; check value is syntax - (cons G G) - (vector 'vector G) - (vector 'struct G) - (vector 'box G) - - (vector 'dots HG (listof (vector-of integer)) nat (listof nat) G) + - (vector 'dots HG (listof (vector-of VarRef)) nat (listof nat) G) - (vector 'app HG G) - (vector 'escaped G) - (vector 'orelse G (vector-of integer) G) @@ -37,6 +36,10 @@ A HeadGuide (HG) is one of: - (vector 'app-opt H (vector-of integer)) - (vector 'orelse-h H (vector-of integer) H) - (vector 'splice G) + +An VarRef is one of + - positive-exact-integer ;; represents depth=0 pvar ref or metafun ref + - negative-exact-integer ;; represents depth>0 pvar ref (within ellipsis) |# (define (head-guide? x) @@ -67,11 +70,19 @@ A HeadGuide (HG) is one of: (define (loop stx g) (translate-g stx0 stx g env-length lenv-mode)) (define (loop-h stx hg) (translate-hg stx0 stx hg env-length lenv-mode)) (define (get index env lenv) (get-var index env lenv lenv-mode)) + (match g + ['_ (lambda (env lenv) stx)] + [(? exact-integer? index) + (check-var index env-length lenv-mode) + (lambda (env lenv) (get index env lenv))] + + [(vector 'check index) (check-var index env-length lenv-mode) (lambda (env lenv) (check-stx stx (get index env lenv)))] + [(cons g1 g2) (let ([f1 (loop (stx-car stx) g1)] [f2 (loop (stx-cdr stx) g2)]) @@ -89,6 +100,7 @@ A HeadGuide (HG) is one of: [else (lambda (env lenv) (cons (f1 env lenv) (f2 env lenv)))]))] + [(vector 'dots ghead henv nesting uptos gtail) ;; At each nesting depth, indexes [0,upto) of lenv* vary; the rest are fixed. ;; An alternative would be to have a list of henvs, but that would inhibit @@ -109,32 +121,55 @@ A HeadGuide (HG) is one of: upto)]) (unless (= lenv*-len last-upto) (error 'template "internal error: last upto was not full env"))) - (cond [(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?) (equal? ghead '-1)) - ;; template was just (pvar ... . T) - (let ([fhead (translate-g stx0 (stx-car stx) ghead env-length 'one)]) + (cond [(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?) + (equal? ghead '-1)) + ;; Fast path for (pvar ... . T) template + ;; - no list? or syntax? checks needed (because ghead is just raw varref) + ;; - avoid trivial map, just append + (let ([var-index (vector-ref henv 0)]) (lambda (env lenv) - (let ([lenv* (get (vector-ref henv 0) env lenv)]) + (let ([lenv* (get var-index env lenv)]) (restx stx (append lenv* (ftail env lenv))))))] [(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?)) - (let ([fhead (translate-g stx0 (stx-car stx) ghead env-length 'one)]) + ;; Fast path for (T ... . T) template + ;; - specialize lenv to avoid vector allocation/mutation + ;; - body is deforested (append (map _ _) _) preserving eval order + ;; - could try to eliminate 'check-list', but probably not worth the bother + (let* ([fhead (translate-g stx0 (stx-car stx) ghead env-length 'one)] + [var-index (vector-ref henv 0)]) (lambda (env lenv) (restx stx - (let dotsloop ([lenv* (get (vector-ref henv 0) env lenv)]) - (if (null? lenv*) - (ftail env lenv) - (cons (fhead env (car lenv*)) - (dotsloop (cdr lenv*))))))))] + (let ([lenv* (check-list stx (get var-index env lenv))]) + (let dotsloop ([lenv* lenv*]) + (if (null? lenv*) + (ftail env lenv) + (cons (fhead env (car lenv*)) + (dotsloop (cdr lenv*)))))))))] [else + ;; Slow/general path for (H ...^n . T) (let ([fhead (if ghead-is-hg? (translate-hg stx0 (stx-car stx) ghead env-length lenv*-len) (translate-g stx0 (stx-car stx) ghead env-length lenv*-len))]) (lambda (env lenv) + #| + The template is "driven" by pattern variables bound to (listof^n syntax). + For example, in (H ... ... . T), the pvars of H have (listof (listof syntax)), + and we need a doubly-nested loop, like + (for/list ([stxlist^1 (in-list stxlist^2)]) + (for/list ([stx (in-list stxlist^1)]) + ___ fhead ___)) + Since we can have arbitrary numbers of ellipses, we have 'nestloop' recur + over ellipsis levels and 'dotsloop' recur over the contents of the pattern + variables' (listof^n syntax) values. + + Also, we reuse env vectors to reduce allocation. For continuation-safety + we must install a continuation barrier around metafunction applications. + |# (define (nestloop lenv* nesting uptos) (cond [(zero? nesting) (fhead env lenv*)] [else - (check-lenv stx lenv*) - (let ([iters (length (vector-ref lenv* 0))]) + (let ([iters (check-lenv/get-iterations stx lenv*)]) (let ([lenv** (make-vector lenv*-len)] [upto** (car uptos)] [uptos** (cdr uptos)]) @@ -142,8 +177,8 @@ A HeadGuide (HG) is one of: (if (zero? iters) null (begin (vector-car/cdr! lenv** lenv* upto**) - (cons (nestloop lenv** (sub1 nesting) uptos**) - (dotsloop (sub1 iters))))))))])) + (let ([row (nestloop lenv** (sub1 nesting) uptos**)]) + (cons row (dotsloop (sub1 iters)))))))))])) (let ([head-results ;; if ghead-is-hg?, is (listof^(nesting+1) stx) -- extra listof for loop-h ;; otherwise, is (listof^nesting stx) @@ -154,13 +189,16 @@ A HeadGuide (HG) is one of: (nested-append head-results (if ghead-is-hg? nesting (sub1 nesting)) tail-result)))))]))] + [(vector 'app ghead gtail) (let ([fhead (loop-h (stx-car stx) ghead)] [ftail (loop (stx-cdr stx) gtail)]) (lambda (env lenv) (restx stx (append (fhead env lenv) (ftail env lenv)))))] + [(vector 'escaped g1) (loop (stx-cadr stx) g1)] + [(vector 'orelse g1 drivers1 g2) (let ([f1 (loop (stx-cadr stx) g1)] [f2 (loop (stx-caddr stx) g2)]) @@ -170,6 +208,7 @@ A HeadGuide (HG) is one of: (if (for/and ([index (in-vector drivers1)]) (get index env lenv)) (f1 env lenv) (f2 env lenv))))] + [(vector 'metafun index g1) (let ([f1 (loop (stx-cdr stx) g1)]) (check-var index env-length lenv-mode) @@ -179,30 +218,36 @@ A HeadGuide (HG) is one of: [old-mark (current-template-metafunction-introducer)] [mf (get index env lenv)]) (parameterize ((current-template-metafunction-introducer mark)) - (let ([r (mf (mark (old-mark v)))]) + (let ([r (call-with-continuation-barrier (lambda () (mf (mark (old-mark v)))))]) (unless (syntax? r) (raise-syntax-error 'template "result of metafunction was not syntax" stx)) (restx stx (old-mark (mark r))))))))] + [(vector 'vector g1) (let ([f1 (loop (vector->list (syntax-e stx)) g1)]) (lambda (env lenv) (restx stx (list->vector (f1 env lenv)))))] + [(vector 'struct g1) (let ([f1 (loop (cdr (vector->list (struct->vector (syntax-e stx)))) g1)] [key (prefab-struct-key (syntax-e stx))]) (lambda (env lenv) (restx stx (apply make-prefab-struct key (f1 env lenv)))))] + [(vector 'box g1) (let ([f1 (loop (unbox (syntax-e stx)) g1)]) (lambda (env lenv) (restx stx (box (f1 env lenv)))))] + [(vector 'copy-props g1 keys) (let ([f1 (loop stx g1)]) (lambda (env lenv) (for/fold ([v (f1 env lenv)]) ([key (in-list keys)]) - ;; FIXME: avoid copying if no value - ;; (if that situation becomes possible in future) - (syntax-property v key (syntax-property stx key)))))] + (let ([pvalue (syntax-property stx key)]) + (if pvalue + (syntax-property v key pvalue) + v)))))] + [(vector 'set-props g1 props-alist) (let ([f1 (loop stx g1)]) (lambda (env lenv) @@ -213,7 +258,9 @@ A HeadGuide (HG) is one of: (define (loop stx g) (translate-g stx0 stx g env-length lenv-mode)) (define (loop-h stx hg) (translate-hg stx0 stx hg env-length lenv-mode)) (define (get index env lenv) (get-var index env lenv lenv-mode)) + (match hg + [(vector 'app-opt hg1 drivers1) (let ([f1 (loop-h (stx-cadr stx) hg1)]) (for ([var (in-vector drivers1)]) @@ -222,6 +269,7 @@ A HeadGuide (HG) is one of: (if (for/and ([index (in-vector drivers1)]) (get index env lenv)) (f1 env lenv) null)))] + [(vector 'orelse-h hg1 drivers1 hg2) (let ([f1 (loop-h (stx-cadr stx) hg1)] [f2 (loop-h (stx-caddr stx) hg2)]) @@ -231,6 +279,7 @@ A HeadGuide (HG) is one of: (if (for/and ([index (in-vector drivers1)]) (get index env lenv)) (f1 env lenv) (f2 env lenv))))] + [(vector 'splice g1) (let ([f1 (loop (stx-cdr stx) g1)]) (lambda (env lenv) @@ -241,7 +290,8 @@ A HeadGuide (HG) is one of: "splicing template did not produce a syntax list" stx)) v*)))] - [else + + [_ (let ([f (loop stx hg)]) (lambda (env lenv) (list (f env lenv))))])) @@ -265,16 +315,18 @@ A HeadGuide (HG) is one of: (else lenv-mode))) (error/bad-index))])) -(define (check-lenv stx lenv) - (for ([v (in-vector lenv)]) - (unless v - (error 'template "pattern variable used in ellipsis pattern is not defined"))) +(define (check-lenv/get-iterations stx lenv) + (unless (list? (vector-ref lenv 0)) + (error 'template "pattern variable used in ellipsis pattern is not defined")) (let ([len0 (length (vector-ref lenv 0))]) (for ([v (in-vector lenv)]) + (unless (list? v) + (error 'template "pattern variable used in ellipsis pattern is not defined")) (unless (= len0 (length v)) (raise-syntax-error 'template "incompatible ellipsis match counts for template" - stx))))) + stx))) + len0)) ;; ---- @@ -313,8 +365,16 @@ A HeadGuide (HG) is one of: v (error/not-stx ctx v))) +(define (check-list ctx v) + (if (list? v) + v + (error/not-list ctx v))) + (define (error/not-stx ctx v) - (raise-syntax-error 'template "pattern variable is not syntax-valued" ctx)) + (raise-syntax-error 'template "pattern variable value is not syntax" ctx)) + +(define (error/not-list ctx v) + (raise-syntax-error 'template "pattern variable value is not syntax list" ctx)) (define (error/bad-index index) (error 'template "internal error: bad index: ~e" index)) diff --git a/collects/syntax/parse/experimental/template.rkt b/collects/syntax/parse/experimental/template.rkt index 8bceed348a..d563295e96 100644 --- a/collects/syntax/parse/experimental/template.rkt +++ b/collects/syntax/parse/experimental/template.rkt @@ -35,43 +35,26 @@ A HeadTemplate (H) is one of: - (?@ . T) |# -(define-syntax (template stx) - (parameterize ((current-syntax-context stx)) - (syntax-case stx () - [(template t) - #'(template t #:properties (paren-shape))] - [(template t #:properties (prop ...)) - (andmap identifier? (syntax->list #'(prop ...))) - (let-values ([(guide deps props-guide) - (parameterize ((retain-props (syntax->datum #'(prop ...)))) - (parse-template #'t))]) - (let ([vars - (for/list ([dep (in-vector deps)]) - (cond [(pvar? dep) - (let* ([sm (pvar-sm dep)] - [valvar (syntax-mapping-valvar sm)] - [attr (syntax-local-value valvar (lambda () #f))]) - (cond [(attribute-mapping? attr) - (attribute-mapping-var attr)] - [else valvar]))] - [(template-metafunction? dep) - (template-metafunction-var dep)] - [else - (error 'template - "internal error: bad environment entry: ~e" - dep)]))]) +(begin-for-syntax + (define (do-template ctx tstx) + (parameterize ((current-syntax-context ctx)) + (let-values ([(guide deps props-guide) (parse-template tstx)]) + (let ([vars + (for/list ([dep (in-vector deps)]) + (cond [(pvar? dep) (pvar-var dep)] + [(template-metafunction? dep) + (template-metafunction-var dep)] + [else + (error 'template + "internal error: bad environment entry: ~e" + dep)]))]) + (with-syntax ([t tstx]) (syntax-arm - (cond [(equal? guide '1) ;; was (template pvar) - (with-syntax ([var (car vars)]) - #'(if (syntax? var) - var - (error/not-stx (quote-syntax t) var)))] - [(equal? guide '_) ;; constant - (cond [(equal? props-guide '_) ;; no props - #`(quote-syntax t)] - [else - (with-syntax ([props-guide props-guide]) - #`(substitute (quote-syntax t) 'props-guide '_ '#()))])] + (cond [(equal? guide '1) + ;; was (template pvar), implies props-guide = '_ + (car vars)] + [(and (equal? guide '_) (equal? props-guide '_)) + #'(quote-syntax t)] [else (with-syntax ([guide guide] [props-guide props-guide] @@ -82,7 +65,17 @@ A HeadTemplate (H) is one of: #'(substitute (quote-syntax t) 'props-guide 'guide - vars-vector))]))))]))) + vars-vector))])))))))) + +(define-syntax (template stx) + (syntax-case stx () + [(template t) + (do-template stx #'t)] + [(template t #:properties (prop ...)) + (andmap identifier? (syntax->list #'(prop ...))) + (parameterize ((props-to-serialize (syntax->datum #'(prop ...))) + (props-to-transfer (syntax->datum #'(prop ...)))) + (do-template stx #'t))])) ;; substitute-table : hash[stx => translated-template] ;; Cache for closure-compiled templates. Key is just syntax of @@ -118,7 +111,7 @@ A HeadTemplate (H) is one of: See private/substitute for definition of Guide (G) and HeadGuide (HG). A env-entry is one of - - (pvar syntax-mapping depth-delta) + - (pvar syntax-mapping attribute-mapping/#f depth-delta) - template-metafunction The depth-delta associated with a depth>0 pattern variable is the difference @@ -148,7 +141,7 @@ instead of integers and integer vectors. |# (begin-for-syntax - (struct pvar (sm dd) #:prefab)) + (struct pvar (sm attr dd) #:prefab)) ;; ============================================================ @@ -170,6 +163,22 @@ instead of integers and integer vectors. (begin-for-syntax + ;; props-to-serialize determines what properties are saved even when + ;; code is compiled. (Unwritable values are dropped.) + ;; props-to-transfer determines what properties are transferred from + ;; template to stx constructed. + ;; If a property is in props-to-transfer but not props-to-serialize, + ;; compiling the module may have caused the property to disappear. + ;; If a property is in props-to-serialize but not props-to-transfer, + ;; it will show up only in constant subtrees. + ;; The behavior of 'syntax' is serialize '(), transfer '(paren-shape). + + ;; props-to-serialize : (parameterof (listof symbol)) + (define props-to-serialize (make-parameter '())) + + ;; props-to-transfer : (parameterof (listof symbol)) + (define props-to-transfer (make-parameter '(paren-shape))) + ;; parse-template : stx -> (values guide (vectorof env-entry) guide) (define (parse-template t) (let-values ([(drivers pre-guide props-guide) (parse-t t 0 #f)]) @@ -196,8 +205,12 @@ instead of integers and integer vectors. (hash-ref main-env x)))) (match g ['_ '_] - [(cons g1 g2) (cons (loop g1 loop-env) (loop g2 loop-env))] - [(? pvar? pvar) (get-index pvar)] + [(cons g1 g2) + (cons (loop g1 loop-env) (loop g2 loop-env))] + [(? pvar? pvar) + (if (pvar-check? pvar) + (vector 'check (get-index pvar)) + (get-index pvar))] [(vector 'dots head new-hdrivers/level nesting '#f tail) (let-values ([(sub-loop-env r-uptos) (for/fold ([env (hash)] [r-uptos null]) @@ -253,25 +266,31 @@ instead of integers and integer vectors. ;; ---------------------------------------- - (define retain-props (make-parameter '(paren-shape))) - (define (wrap-props stx env-set pre-guide props-guide) - (let ([prop-entries + (let ([saved-prop-values (if (syntax? stx) - (for/fold ([entries null]) ([prop (in-list (retain-props))]) + (for/fold ([entries null]) ([prop (in-list (props-to-serialize))]) (let ([v (syntax-property stx prop)]) (if (and v (quotable? v)) (cons (cons prop v) entries) entries))) + null)] + [copy-props + (if (syntax? stx) + (for/list ([prop (in-list (props-to-transfer))] + #:when (syntax-property stx prop)) + prop) null)]) - (if (pair? prop-entries) - (values env-set - (cond [(eq? pre-guide '_) - ;; No need to copy props; already on constant. - '_] - [else (vector 'copy-props pre-guide (map car prop-entries))]) - (vector 'set-props props-guide prop-entries)) - (values env-set pre-guide props-guide)))) + (values env-set + (cond [(eq? pre-guide '_) + ;; No need to copy props; already on constant + '_] + [(pair? copy-props) + (vector 'copy-props pre-guide copy-props)] + [else pre-guide]) + (if (pair? saved-prop-values) + (vector 'set-props props-guide saved-prop-values) + props-guide)))) (define (quotable? v) (or (null? v) @@ -294,7 +313,7 @@ instead of integers and integer vectors. (define (list-guide . gs) (foldr cons-guide '_ gs)) - ;; parse-t : stx nat boolean -> (values (setof env-entry) pre-guide) + ;; parse-t : stx nat boolean -> (values (setof env-entry) pre-guide props-guide) (define (parse-t t depth esc?) (syntax-case t (?? ?@) [id @@ -405,7 +424,7 @@ instead of integers and integer vectors. [const (wrap-props t (set) '_ '_)])) - ;; parse-h : stx nat boolean -> (values (setof env-entry) boolean pre-head-guide) + ;; parse-h : stx nat boolean -> (values (setof env-entry) boolean pre-head-guide props-guide) (define (parse-h h depth esc?) (syntax-case h (?? ?@) [(?? t) @@ -439,13 +458,15 @@ instead of integers and integer vectors. (define (lookup id depth) (let ([v (syntax-local-value id (lambda () #f))]) (cond [(syntax-pattern-variable? v) - (let ([pvar-depth (syntax-mapping-depth v)]) + (let* ([pvar-depth (syntax-mapping-depth v)] + [attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))] + [attr (and (attribute-mapping? attr) attr)]) (cond [(not depth) ;; not looking for pvars, only for metafuns #f] [(zero? pvar-depth) - (pvar v #f)] + (pvar v attr #f)] [(>= depth pvar-depth) - (pvar v (- depth pvar-depth))] + (pvar v attr (- depth pvar-depth))] [else (wrong-syntax id (string-append "pattern variable used at wrong ellipsis depth " @@ -454,10 +475,13 @@ instead of integers and integer vectors. [(template-metafunction? v) v] [else - ;; id is a literal; check that for all x s.t. id = x.y, x is not a pattern variable + ;; id is a literal; check that for all x s.t. id = x.y, x is not an attribute (for ([pfx (in-list (dotted-prefixes id))]) - (when (syntax-pattern-variable? (syntax-local-value pfx (lambda () #f))) - (wrong-syntax id "undefined nested attribute of attribute `~a'" (syntax-e pfx)))) + (let ([pfx-v (syntax-local-value pfx (lambda () #f))]) + (when (and (syntax-pattern-variable? pfx-v) + (let ([valvar (syntax-mapping-valvar pfx-v)]) + (attribute-mapping? (syntax-local-value valvar (lambda () #f))))) + (wrong-syntax id "undefined nested attribute of attribute `~a'" (syntax-e pfx))))) #f]))) (define (dotted-prefixes id) @@ -474,9 +498,19 @@ instead of integers and integer vectors. (define ((pvar/dd<=? expected-dd) x) (match x - [(pvar sm dd) (and dd (<= dd expected-dd))] + [(pvar sm attr dd) (and dd (<= dd expected-dd))] [_ #f])) + (define (pvar-var x) + (match x + [(pvar sm '#f dd) (syntax-mapping-valvar sm)] + [(pvar sm attr dd) (attribute-mapping-var attr)])) + + (define (pvar-check? x) + (match x + [(pvar sm '#f dd) #f] + [(pvar sm attr dd) (not (attribute-mapping-syntax? attr))])) + (define (stx-drop n x) (cond [(zero? n) x] [else (stx-drop (sub1 n) (stx-cdr x))]))