From 034cde0a973bc9271f90605db43b4d4f29361dba Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sat, 12 Aug 2017 21:45:15 -0400 Subject: [PATCH] syntax/parse template: track syntax vs non-syntax pairs in template Allows generation of more specialized code (hopefully smaller and faster). Also clean up some other guide reps. --- parse/experimental/template.rkt | 269 +++++++++++++++++--------------- 1 file changed, 146 insertions(+), 123 deletions(-) diff --git a/parse/experimental/template.rkt b/parse/experimental/template.rkt index b51a638..7f3f052 100644 --- a/parse/experimental/template.rkt +++ b/parse/experimental/template.rkt @@ -209,9 +209,13 @@ instead of integers and integer vectors. (if (pvar-check? pvar) #`(t-check #,(lookup pvar) '#,in-try?) #`(t-var #,(lookup pvar)))] - [(cons g1 g2) + [(vector 'cons g1 g2) #`(t-cons #,(loop g1) #,(loop g2))] - [(vector 'dots head new-driverss nesting '#f tail) + [(vector 'cons/p g1 g2) + #`(t-cons/p #,(loop g1) #,(loop g2))] + [(vector 'cons/x g1 g2) + #`(t-cons/x #,(loop g1) #,(loop g2))] + [(vector 'dots head new-driverss nesting tail) (let () (define cons? (not (head-guide? head))) ;; AccElem = Stx if cons? is true, (Listof Stx) otherwise @@ -246,10 +250,10 @@ instead of integers and integer vectors. (if cons? #`(t-dots1 (lambda (stx) (#,head-loop-code null)) '#,nesting #,(loop tail)) #`(t-dots (lambda (stx) (#,head-loop-code null)) '#,nesting #,(loop tail))))] - [(vector 'app head tail) - (if (head-guide? head) - #`(t-app #,(loop-h head) #,(loop tail)) - #`(t-cons #,(loop head) #,(loop tail)))] + [(vector 'append/p head tail) + #`(t-append/p #,(loop-h head) #,(loop tail))] + [(vector 'append/x head tail) + #`(t-append/x #,(loop-h head) #,(loop tail))] [(vector 'escaped g1) #`(t-escaped #,(loop g1))] [(vector 'orelse g1 g2) @@ -266,13 +270,13 @@ instead of integers and integer vectors. #`(t-unsyntax #,var)] [(vector 'relocate g1 var) #`(t-relocate #,(loop g1) #,var)] - [else (error 'template "internal error: bad pre-guide: ~e" g)])) + [else (error 'template "internal error: bad guide: ~e" g)])) (define (compile-h g in-try?) (define (loop g) (compile-t g in-try?)) (define (loop-h g) (compile-h g in-try?)) (match g [(vector 'orelse-h1 g1) - #`(t-orelse-h1 #,(compile-h g1 #t))] + #`(t-orelse #,(compile-h g1 #t) #f)] [(vector 'orelse-h g1 g2) #`(t-orelse #,(compile-h g1 #t) #,(loop-h g2))] [(vector 'splice g1) @@ -302,11 +306,13 @@ instead of integers and integer vectors. (match g ['_ (relocate g)] - [(cons g1 g2) + [(vector 'cons g1 g2) + (relocate g)] + [(vector 'cons/x g1 g2) (relocate g)] [(? pvar? g) g] - [(vector 'dots head new-hdrivers/level nesting '#f tail) + [(vector 'dots head new-hdrivers/level nesting tail) ;; Ideally, should error. For perfect backwards compatability, ;; should relocate. But if there are zero iterations, that ;; means we'd relocate tail (which might be bad). Making @@ -324,7 +330,7 @@ instead of integers and integer vectors. [(vector 'unsyntax var) g] ;; ---- - [(vector 'app ghead gtail) + [(vector 'append/x ghead gtail) (match ghead [(vector 'unsyntax-splicing _) g] [_ (error/no-relocate)])] @@ -351,14 +357,110 @@ instead of integers and integer vectors. ;; QuasiPairs = (listof (cons/c identifier syntax)) (define quasi (make-parameter #f)) - (define (cons-guide g1 g2) - (if (and (eq? g1 '_) (eq? g2 '_)) '_ (cons g1 g2))) + (define (stx-dots? x) (and (identifier? x) (free-identifier=? x (quote-syntax ...)))) - (define (list-guide . gs) - (foldr cons-guide '_ gs)) + (define (cons-guide g1 g2) + (if (and (eq? g1 '_) (eq? g2 '_)) '_ (vector 'cons g1 g2))) + (define (cons/p-guide g1 g2) + (if (and (eq? g1 '_) (eq? g2 '_)) '_ (vector 'cons/p g1 g2))) + (define (cons/x-guide g1 g2) + (if (and (eq? g1 '_) (eq? g2 '_)) '_ (vector 'cons/x g1 g2))) + + (define (list-guide . gs) (foldr cons-guide '_ gs)) + (define (list/p-guide . gs) (foldr cons/p-guide '_ gs)) + (define (list/x-guide . gs) (foldr cons/x-guide '_ gs)) ;; parse-t : stx nat boolean -> (values (dsetof env-entry) pre-guide) (define (parse-t t depth esc?) + (cond [(stx-pair? t) + (if (identifier? (stx-car t)) + (parse-t-pair/command t depth esc?) + (parse-t-pair/dots t depth esc?))] + [else (parse-t-nonpair t depth esc?)])) + + ;; parse-t-pair/command : Stx Nat Boolean -> ... + ;; t is a stxpair w/ id in car; check if it is a "command" (metafun, escape, etc) + (define (parse-t-pair/command t depth esc?) + (syntax-case t (quasitemplate unsyntax ??) + [(quasitemplate template) + (quasi) + (parameterize ((quasi (list (quasi)))) + (let-values ([(drivers guide) (parse-t #'template depth esc?)]) + (values drivers (list-guide '_ guide))))] + [(unsyntax e) + (quasi) + (let ([qval (quasi)]) + (cond [(box? qval) + (with-syntax ([(tmp) (generate-temporaries #'(unsyntax-expr))]) + (set-box! qval (cons (cons #'tmp t) (unbox qval))) + (values (dset) (vector 'unsyntax #'tmp)))] + [else + (parameterize ((quasi (car qval))) + (let-values ([(drivers guide) (parse-t #'e depth esc?)]) + (values drivers (list-guide '_ guide))))]))] + [(DOTS template) + (and (not esc?) (free-identifier=? #'DOTS (quote-syntax ...))) + (let-values ([(drivers guide) (parse-t #'template depth #t)]) + (values drivers (vector 'escaped guide)))] + [(?? t1 t2) + (not esc?) + (let-values ([(drivers1 guide1) (parse-t #'t1 depth esc?)] + [(drivers2 guide2) (parse-t #'t2 depth esc?)]) + (values (dset-union drivers1 drivers2) (vector 'orelse guide1 guide2)))] + [(mf . _) + (and (not esc?) (template-metafunction? (lookup #'mf #f))) + (let-values ([(mf) (lookup #'mf #f)] + [(drivers guide) (parse-t (stx-cdr t) depth esc?)]) + (values drivers (vector 'metafun mf guide)))] + [_ (parse-t-pair/dots t depth esc?)])) + + ;; parse-t-pair/dots : Stx Nat Boolean -> ... + ;; t is a stx pair; check for dots + (define (parse-t-pair/dots t depth esc?) + (define head (stx-car t)) + (define-values (tail nesting) + (let loop ([tail (stx-cdr t)] [nesting 0]) + (if (and (not esc?) (stx-pair? tail) (stx-dots? (stx-car tail))) + (loop (stx-cdr tail) (add1 nesting)) + (values tail nesting)))) + (if (zero? nesting) + (parse-t-pair/normal t depth esc?) + (let-values ([(hdrivers hguide) (parse-h head (+ depth nesting) esc?)] + [(tdrivers tguide) (parse-t tail depth esc?)]) + (when (dset-empty? hdrivers) + (wrong-syntax head "no pattern variables before ellipsis in template")) + (when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth))) + (let ([bad-dots ;; select the nestingth (last) ellipsis as the bad one + (stx-car (stx-drop nesting t))]) + ;; FIXME: improve error message? + (wrong-syntax bad-dots "too many ellipses in template"))) + (values (dset-union hdrivers tdrivers) + ;; hdrivers is (listof (dsetof pvar)); compute pvars new to each level + (let* ([hdrivers/level + (for/list ([i (in-range nesting)]) + (dset-filter hdrivers (pvar/dd<=? (+ depth i))))] + [new-hdrivers/level + (let loop ([raw hdrivers/level] [last (dset)]) + (cond [(null? raw) null] + [else + (cons (dset->list (dset-subtract (car raw) last)) + (loop (cdr raw) (car raw)))]))]) + (vector 'dots hguide new-hdrivers/level nesting tguide)))))) + + ;; parse-t-pair/normal : Stx Nat Boolean -> ... + ;; t is a normal stx pair + (define (parse-t-pair/normal t depth esc?) + (define-values (hdrivers hguide) (parse-h (stx-car t) depth esc?)) + (define-values (tdrivers tguide) (parse-t (stx-cdr t) depth esc?)) + (values (dset-union hdrivers tdrivers) + (let ([kind (if (head-guide? hguide) + (if (syntax? t) 'append/x 'append/p) + (if (syntax? t) 'cons/x 'cons/p))]) + (vector kind hguide tguide)))) + + ;; parse-t-nonpair : Stx Nat Boolean -> ... + ;; PRE: t is not a stxpair + (define (parse-t-nonpair t depth esc?) (syntax-case t (?? ?@ unsyntax quasitemplate) [id (identifier? #'id) @@ -378,84 +480,6 @@ instead of integers and integer vectors. (wrong-syntax t "illegal use of syntax metafunction")] [else (values (dset) '_)]))])] - [(mf . template) - (and (not esc?) - (identifier? #'mf) - (template-metafunction? (lookup #'mf #f))) - (let-values ([(mf) (lookup #'mf #f)] - [(drivers guide) (parse-t #'template depth esc?)]) - (values drivers (vector 'metafun mf guide)))] - [(unsyntax t1) - (quasi) - (let ([qval (quasi)]) - (cond [(box? qval) - (with-syntax ([(tmp) (generate-temporaries #'(unsyntax-expr))]) - (set-box! qval (cons (cons #'tmp t) (unbox qval))) - (values (dset) (vector 'unsyntax #'tmp)))] - [else - (parameterize ((quasi (car qval))) - (let-values ([(drivers guide) (parse-t #'t1 depth esc?)]) - (values drivers (list-guide '_ guide))))]))] - [(quasitemplate t1) - ;; quasitemplate escapes inner unsyntaxes - (quasi) - (parameterize ((quasi (list (quasi)))) - (let-values ([(drivers guide) (parse-t #'t1 depth esc?)]) - (values drivers (list-guide '_ guide))))] - [(DOTS template) - (and (not esc?) - (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) - (let-values ([(drivers guide) (parse-t #'template depth #t)]) - (values drivers (vector 'escaped guide)))] - [(?? t1 t2) - (not esc?) - (let-values ([(drivers1 guide1) (parse-t #'t1 depth esc?)] - [(drivers2 guide2) (parse-t #'t2 depth esc?)]) - (values (dset-union drivers1 drivers2) (vector 'orelse guide1 guide2)))] - [(head DOTS . tail) - (and (not esc?) - (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) - (let-values ([(nesting tail) - (let loop ([nesting 1] [tail #'tail]) - (syntax-case tail () - [(DOTS . tail) - (and (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) - (loop (add1 nesting) #'tail)] - [else (values nesting tail)]))]) - (let-values ([(hdrivers _hsplice? hguide) - (parse-h #'head (+ depth nesting) esc?)] - [(tdrivers tguide) - (parse-t tail depth esc?)]) - (when (dset-empty? hdrivers) - (wrong-syntax #'head "no pattern variables before ellipsis in template")) - (when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth))) - ;; FIXME: improve error message? - (let ([bad-dots - ;; select the nestingth (last) ellipsis as the bad one - (stx-car (stx-drop nesting t))]) - (wrong-syntax bad-dots "too many ellipses in template"))) - (values (dset-union hdrivers tdrivers) - ;; pre-guide hdrivers is (listof (setof pvar)) - ;; set of pvars new to each level - (let* ([hdrivers/level - (for/list ([i (in-range nesting)]) - (dset-filter hdrivers (pvar/dd<=? (+ depth i))))] - [new-hdrivers/level - (let loop ([raw hdrivers/level] [last (dset)]) - (cond [(null? raw) null] - [else - (cons (dset->list (dset-subtract (car raw) last)) - (loop (cdr raw) (car raw)))]))]) - (vector 'dots hguide new-hdrivers/level nesting #f tguide)))))] - [(head . tail) - (let-values ([(hdrivers hsplice? hguide) - (parse-h #'head depth esc?)] - [(tdrivers tguide) - (parse-t #'tail depth esc?)]) - (values (dset-union hdrivers tdrivers) - (cond [(and (eq? hguide '_) (eq? tguide '_)) '_] - [hsplice? (vector 'app hguide tguide)] - [else (cons hguide tguide)])))] [vec (vector? (syntax-e #'vec)) (let-values ([(drivers guide) @@ -473,41 +497,40 @@ instead of integers and integer vectors. [const (values (dset) '_)])) - ;; parse-h : stx nat boolean -> (values (dsetof env-entry) boolean pre-head-guide) + ;; parse-h : Syntax Nat Boolean -> (values (dsetof PVar) HeadGuide) (define (parse-h h depth esc?) (syntax-case h (?? ?@ unsyntax-splicing) [(?? t) (not esc?) - (let-values ([(drivers splice? guide) - (parse-h #'t depth esc?)]) - (values drivers #t (vector 'orelse-h1 guide)))] + (let-values ([(drivers guide) (parse-h #'t depth esc?)]) + (values drivers (vector 'orelse-h1 guide)))] [(?? t1 t2) (not esc?) - (let-values ([(drivers1 splice?1 guide1) (parse-h #'t1 depth esc?)] - [(drivers2 splice?2 guide2) (parse-h #'t2 depth esc?)]) + (let-values ([(drivers1 guide1) (parse-h #'t1 depth esc?)] + [(drivers2 guide2) (parse-h #'t2 depth esc?)]) (values (dset-union drivers1 drivers2) - (or splice?1 splice?2) - (vector (if (or splice?1 splice?2) 'orelse-h 'orelse) - guide1 guide2)))] - [(?@ . t) + (if (or (head-guide? guide1) (head-guide? guide2)) + (vector 'orelse-h guide1 guide2) + (vector 'orelse guide1 guide2))))] + [(?@ . _) (not esc?) - (let-values ([(drivers guide) (parse-t #'t depth esc?)]) - (values drivers #t (vector 'splice guide)))] + (let-values ([(drivers guide) (parse-t (stx-cdr h) depth esc?)]) + (values drivers (vector 'splice guide)))] [(unsyntax-splicing t1) (quasi) (let ([qval (quasi)]) (cond [(box? qval) (with-syntax ([(tmp) (generate-temporaries #'(unsyntax-splicing-expr))]) (set-box! qval (cons (cons #'tmp h) (unbox qval))) - (values (dset) #t (vector 'unsyntax-splicing #'tmp)))] + (values (dset) (vector 'unsyntax-splicing #'tmp)))] [else (parameterize ((quasi (car qval))) (let*-values ([(drivers guide) (parse-t #'t1 depth esc?)] [(drivers guide) (values drivers (list-guide '_ guide))]) - (values drivers #f guide)))]))] + (values drivers guide)))]))] [t (let-values ([(drivers guide) (parse-t #'t depth esc?)]) - (values drivers #f guide))])) + (values drivers guide))])) (define (lookup id depth) (let ([v (syntax-local-value/record id (lambda (v) (or (syntax-pattern-variable? v) @@ -570,19 +593,22 @@ instead of integers and integer vectors. #| A Guide (G) is one of: - - '_ - - VarRef ;; no syntax check - - (cons G G) + - '_ ;; constant + - PVar ;; pattern variable + - (vector 'cons G G) ;; template is pair or syntax-pair => restx, use stx-{car,cdr} + - (vector 'cons/p G G) ;; template is non-syntax pair => no restx, use {car,cdr} + - (vector 'cons/x G G) ;; template is syntax-pair => restx, use {car,cdr}+syntax-e - (vector 'vector G) - (vector 'struct G) - (vector 'box G) - - (vector 'dots HG (listof (listof VarRef)) nat (listof nat) G) - - (vector 'app HG G) + - (vector 'dots HG (listof (listof PVar)) Nat G) + - (vector 'append/p HG G) ;; template is non-syntax pair => no restx, use {car,cdr} + - (vector 'append/x HG G) ;; template is syntax-pair => restx, use {car,cdr}+syntax-e - (vector 'escaped G) - (vector 'orelse G G) - - (vector 'metafun integer G) + - (vector 'metafun Metafunction G) - (vector 'unsyntax Id) - - (vector 'relocate G) + - (vector 'relocate G Id) A HeadGuide (HG) is one of: - G @@ -590,23 +616,23 @@ A HeadGuide (HG) is one of: - (vector 'orelse-h H H) - (vector 'splice G) - (vector 'unsyntax-splicing Id) - -A VarRef is an identifier. |# (define ((t-const) stx) stx) (define ((t-var v) stx) v) (define ((t-check v in-try?) stx) (check-stx stx v in-try?)) -(define ((t-app h t) stx) (restx stx (append (h (stx-car stx)) (t (stx-cdr stx))))) +(define ((t-append/p h t) stx) (append (h (car stx)) (t (cdr stx)))) +(define ((t-append/x h t) stx) (restx stx (append (h (car (syntax-e stx))) (t (cdr (syntax-e stx)))))) (define ((t-cons h t) stx) (restx stx (cons (h (stx-car stx)) (t (stx-cdr stx))))) -(define ((t-cons* h t) stx) (cons (h (car stx)) (t (cdr stx)))) +(define ((t-cons/p h t) stx) (cons (h (car stx)) (t (cdr stx)))) +(define ((t-cons/x h t) stx) (restx stx (cons (h (car (syntax-e stx))) (t (cdr (syntax-e stx)))))) (define ((t-dots h n t) stx) (restx stx (revappend* (h (stx-car stx)) (t (stx-drop (add1 n) stx))))) (define ((t-dots1 h n t) stx) (restx stx (revappend (h (stx-car stx)) (t (stx-drop (add1 n) stx))))) (define ((t-escaped g) stx) (g (stx-cadr stx))) (define ((t-orelse g1 g2) stx) - (with-handlers ([absent-pvar? (lambda (e) (g2 (stx-caddr stx)))]) + (with-handlers ([absent-pvar? (lambda (e) (if g2 (g2 (stx-caddr stx)) null))]) (g1 (stx-cadr stx)))) (define ((t-metafun mf g) stx) (define v (restx stx (cons (stx-car stx) (g (stx-cdr stx))))) @@ -626,9 +652,6 @@ A VarRef is an identifier. (restx stx (apply make-prefab-struct key (g elems)))) (define ((t-box g) stx) (restx stx (box (g (unbox (syntax-e stx)))))) (define ((t-h g) stx) (list (g stx))) -(define ((t-orelse-h1 g) stx) - (with-handlers ([absent-pvar? (lambda (e) null)]) - (g (stx-cadr stx)))) (define ((t-splice g) stx) (let ([r (g (stx-cdr stx))]) (or (stx->list r)