From ab9207dbc730901cfe8d4dd90171f227b76f0ea9 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sun, 10 Mar 2013 12:52:30 -0400 Subject: [PATCH] split out pattern optimization code --- collects/syntax/parse/private/opt.rkt | 410 +++++++++++++++++ collects/syntax/parse/private/parse.rkt | 572 +++++------------------- 2 files changed, 528 insertions(+), 454 deletions(-) create mode 100644 collects/syntax/parse/private/opt.rkt diff --git a/collects/syntax/parse/private/opt.rkt b/collects/syntax/parse/private/opt.rkt new file mode 100644 index 0000000000..410f865647 --- /dev/null +++ b/collects/syntax/parse/private/opt.rkt @@ -0,0 +1,410 @@ +#lang racket/base +(require syntax/stx + syntax/private/id-table + syntax/keyword + racket/syntax + racket/pretty + syntax/parse/private/residual-ct ;; keep abs. path + "minimatch.rkt" + "rep-attrs.rkt" + "rep-data.rkt" + "rep-patterns.rkt" + "rep.rkt" + "kws.rkt") +(provide (struct-out pk1) + (rename-out [optimize-matrix0 optimize-matrix])) + +;; controls debugging output for optimization successes and failures +(define DEBUG-OPT-SUCCEED #f) +(define DEBUG-OPT-FAIL #f) + +;; ---- + +;; A Matrix is a (listof PK) where each PK has same number of columns +;; A PK is one of +;; - (pk1 (listof pattern) expr) -- a simple row in a parsing matrix +;; - (pk/same pattern Matrix) -- a submatrix with a common first column factored out +;; - (pk/pair Matrix) -- a submatrix with pair patterns in the first column unfolded +;; - (pk/and Matrix) -- a submatrix with and patterns in the first column unfolded +(struct pk1 (patterns k) #:prefab) +(struct pk/same (pattern inner) #:prefab) +(struct pk/pair (inner) #:prefab) +(struct pk/and (inner) #:prefab) + +(define (pk-columns pk) + (match pk + [(pk1 patterns k) (length patterns)] + [(pk/same p inner) (add1 (pk-columns inner))] + [(pk/pair inner) (sub1 (pk-columns inner))] + [(pk/and inner) (sub1 (pk-columns inner))])) + +;; Can factor pattern P given clauses like +;; [ P P1 ... | e1] [ | [P1 ... | e1] ] +;; [ P ⋮ | ⋮] => [P | [ ⋮ | ⋮] ] + ; [ P PN ... | eN] [ | [PN ... | eN] ] +;; if P cannot cut and P succeeds at most once (otherwise may reorder backtracking) + +;; Can unfold pair patterns as follows: +;; [ (P11 . P12) P1 ... | e1 ] [ P11 P12 P1 ... | e1 ] +;; [ ⋮ ⋮ | ⋮ ] => check pair, [ ⋮ | ⋮ ] +;; [ (PN1 . PN2) PN ... | eN ] [ PN1 PN2 PN ... | eN ] + +;; Can unfold ~and patterns similarly; ~and patterns can hide +;; factoring opportunities. + +;; ---- + +(define (optimize-matrix0 rows) + (define result (optimize-matrix rows)) + #| + (when DEBUG-OPT-SUCCEED + (let ([sexpr (matrix->sexpr result)]) + (unless (equal? (car sexpr) 'MATCH) + (eprintf "%% optimized matrix (~s):\n" (length rows)) + (pretty-write (matrix->sexpr result) (current-error-port))))) + |# + result) + +;; optimize-matrix : (listof pk1) -> Matrix +(define (optimize-matrix rows) + (cond [(null? rows) null] + [(null? (cdr rows)) rows] ;; no opportunities for 1 row + [(null? (pk1-patterns (car rows))) rows] + [else + ;; first unfold and-patterns + (let-values ([(col1 col2) + (for/lists (col1 col2) ([row (in-list rows)]) + (unfold-and (car (pk1-patterns row)) null))]) + (cond [(ormap pair? col2) + (list + (pk/and + (optimize-matrix* + (for/list ([row (in-list rows)] + [col1 (in-list col1)] + [col2 (in-list col2)]) + (pk1 (list* col1 + (make-and-pattern col2) + (cdr (pk1-patterns row))) + (pk1-k row))))))] + [else (optimize-matrix* rows)]))])) + +;; optimize-matrix* : (listof pk1) -> Matrix +;; The matrix is nonempty, and first column has no unfoldable pat:and. +;; Split into submatrixes (sequences of rows) starting with similar patterns, +;; handle according to similarity, then recursively optimize submatrixes. +(define (optimize-matrix* rows) + (define row1 (car rows)) + (define pat1 (car (pk1-patterns row1))) + (define k1 (pk1-k row1)) + ;; Now accumulate rows starting with patterns like pat1 + (define-values (like? combine) (pattern->partitioner pat1)) + (let loop ([rows (cdr rows)] [rrows (list row1)]) + (cond [(null? rows) + (cons (combine (reverse rrows)) null)] + [else + (define row1 (car rows)) + (define pat1 (car (pk1-patterns row1))) + (cond [(like? pat1) + (loop (cdr rows) (cons row1 rrows))] + [else + (cons (combine (reverse rrows)) + (optimize-matrix* rows))])]))) + +;; pattern->partitioner : pattern -> (values (pattern -> boolean) ((listof pk1) -> PK)) +(define (pattern->partitioner pat1) + (match pat1 + [(pat:pair attrs head tail) + (values pat:pair? + (lambda (rows) + (cond [(> (length rows) 1) + (when DEBUG-OPT-SUCCEED + (eprintf "** pairs (~s)\n" (length rows))) + (pk/pair (optimize-matrix + (for/list ([row (in-list rows)]) + (let* ([patterns (pk1-patterns row)] + [pat1 (car patterns)]) + (pk1 (list* (pat:pair-head pat1) + (pat:pair-tail pat1) + (cdr patterns)) + (pk1-k row))))))] + [else (car rows)])))] + [(? pattern-factorable?) + (values (lambda (pat2) (pattern-equal? pat1 pat2)) + (lambda (rows) + (cond [(> (length rows) 1) + (when DEBUG-OPT-SUCCEED + (eprintf "** factored(~s): ~e\n" (length rows) (syntax->datum #`#,pat1))) + (pk/same pat1 + (optimize-matrix + (for/list ([row (in-list rows)]) + (pk1 (cdr (pk1-patterns row)) (pk1-k row)))))] + [else (car rows)])))] + [_ + (values (lambda (pat2) + (when DEBUG-OPT-FAIL + (when (pattern-equal? pat1 pat2) + (eprintf "** cannot factor: ~e\n" (syntax->datum #`#,pat2)))) + #f) + (lambda (rows) + ;; (length rows) = 1 + (car rows)))])) + +;; unfold-and : pattern (listof pattern) -> (values pattern (listof pattern)) +(define (unfold-and p onto) + (match p + [(pat:and _as subpatterns) + ;; pat:and is worth unfolding if first subpattern is not pat:action + ;; if first subpattern is also pat:and, keep unfolding + (let* ([first-sub (car subpatterns)] + [rest-subs (cdr subpatterns)]) + (cond [(not (pat:action? first-sub)) + (when #f ;; DEBUG-OPT-SUCCEED + (eprintf ">> unfolding: ~e\n" p)) + (unfold-and first-sub (*append rest-subs onto))] + [else (values p onto)]))] + [_ (values p onto)])) + +(define (pattern-factorable? p) + ;; Can factor out p if p can succeed at most once, does not cut + ;; - if p can succeed multiple times, then factoring changes success order + ;; - if p can cut, then factoring changes which choice points are discarded (too few) + (match p + [(pat:any _as) #t] + [(pat:var _as _n _p _argu _na _ac commit? _r) + ;; commit? implies delimit-cut + commit?] + [(? pat:integrated?) #t] + [(pat:literal _as _lit _ip _lp) #t] + [(pat:datum _as _datum) #t] + [(pat:action _as _act _pat) #f] + [(pat:head _as head tail) + (and (pattern-factorable? head) + (pattern-factorable? tail))] + [(pat:dots _as heads tail) + ;; Conservative approximation for common case: one head pattern + ;; In general, check if heads don't overlap, don't overlap with tail. + (and (= (length heads) 1) + (let ([head (car heads)]) + (and (pattern-factorable? head))) + (equal? tail (create-pat:datum '())))] + [(pat:and _as patterns) + (andmap pattern-factorable? patterns)] + [(pat:or _as patterns) #f] + [(pat:not _as pattern) #f] ;; FIXME: ? + [(pat:pair _as head tail) + (and (pattern-factorable? head) + (pattern-factorable? tail))] + [(pat:vector _as pattern) + (pattern-factorable? pattern)] + [(pat:box _as pattern) + (pattern-factorable? pattern)] + [(pat:pstruct _as key pattern) + (pattern-factorable? pattern)] + [(pat:describe _as pattern _desc _trans _role) + (pattern-factorable? pattern)] + [(pat:delimit _as pattern) + (pattern-factorable? pattern)] + [(pat:commit _as pattern) #t] + [(? pat:reflect?) #f] + [(pat:post _as pattern) + (pattern-factorable? pattern)] + ;; ---- + [(hpat:var _as _name _parser _argu _na _ac commit? _role) + commit?] + [(hpat:seq _as inner) + (pattern-factorable? inner)] + [(hpat:commit _as inner) #t] + ;; ---- + [(ehpat _as head repc) + (and (equal? repc #f) + (pattern-factorable? head))] + ;; ---- + [else #f])) + +(define (subpatterns-equal? as bs) + (and (= (length as) (length bs)) + (for/and ([a (in-list as)] + [b (in-list bs)]) + (pattern-equal? a b)))) + +(define (pattern-equal? a b) + (define result + (cond [(and (pat:any? a) (pat:any? b)) #t] + [(and (pat:var? a) (pat:var? b)) + (and (free-id/f-equal? (pat:var-parser a) (pat:var-parser b)) + (equal-iattrs? (pat:var-attrs a) (pat:var-attrs b)) + (equal-argu? (pat:var-argu a) (pat:var-argu b)) + (expr-equal? (pat:var-role a) (pat:var-role b)))] + [(and (pat:integrated? a) (pat:integrated? b)) + (and (free-identifier=? (pat:integrated-predicate a) + (pat:integrated-predicate b)) + (equal-iattrs? (pat:integrated-attrs a) + (pat:integrated-attrs b)) + (expr-equal? (pat:integrated-role a) (pat:integrated-role b)))] + [(and (pat:literal? a) (pat:literal? b)) + ;; literals are hard to compare, so compare gensyms attached to + ;; literal ids (see rep.rkt) instead + (let ([ka (syntax-property (pat:literal-id a) 'literal)] + [kb (syntax-property (pat:literal-id b) 'literal)]) + (and ka kb (eq? ka kb)))] + [(and (pat:datum? a) (pat:datum? b)) + (equal? (pat:datum-datum a) + (pat:datum-datum b))] + [(and (pat:head? a) (pat:head? b)) + (and (pattern-equal? (pat:head-head a) (pat:head-head b)) + (pattern-equal? (pat:head-tail a) (pat:head-tail b)))] + [(and (pat:dots? a) (pat:dots? b)) + (and (subpatterns-equal? (pat:dots-heads a) (pat:dots-heads b)) + (pattern-equal? (pat:dots-tail a) (pat:dots-tail b)))] + [(and (pat:and? a) (pat:and? b)) + (subpatterns-equal? (pat:and-patterns a) (pat:and-patterns b))] + [(and (pat:or? a) (pat:or? b)) + (subpatterns-equal? (pat:or-patterns a) (pat:or-patterns b))] + [(and (pat:not? a) (pat:not? b)) + (pattern-equal? (pat:not-pattern a) (pat:not-pattern b))] + [(and (pat:pair? a) (pat:pair? b)) + (and (pattern-equal? (pat:pair-head a) (pat:pair-head b)) + (pattern-equal? (pat:pair-tail a) (pat:pair-tail b)))] + [(and (pat:vector? a) (pat:vector? b)) + (pattern-equal? (pat:vector-pattern a) (pat:vector-pattern b))] + [(and (pat:box? a) (pat:box? b)) + (pattern-equal? (pat:box-pattern a) (pat:box-pattern b))] + [(and (pat:pstruct? a) (pat:pstruct? b)) + (and (equal? (pat:pstruct-key a) + (pat:pstruct-key b)) + (pattern-equal? (pat:pstruct-pattern a) + (pat:pstruct-pattern b)))] + [(and (pat:describe? a) (pat:describe? b)) #f] ;; can't compare desc exprs + [(and (pat:delimit? a) (pat:delimit? b)) + (pattern-equal? (pat:delimit-pattern a) (pat:delimit-pattern b))] + [(and (pat:commit? a) (pat:commit? b)) + (pattern-equal? (pat:commit-pattern a) (pat:commit-pattern b))] + [(and (pat:reflect? a) (pat:reflect? b)) #f] ;; FIXME: ? + [(and (pat:post? a) (pat:post? b)) + (pattern-equal? (pat:post-pattern a) (pat:post-pattern b))] + ;; --- + [(and (hpat:var? a) (hpat:var? b)) + (and (free-id/f-equal? (hpat:var-parser a) (hpat:var-parser b)) + (equal-iattrs? (hpat:var-attrs a) (hpat:var-attrs b)) + (equal-argu? (hpat:var-argu a) (hpat:var-argu b)) + (expr-equal? (hpat:var-role a) (hpat:var-role b)))] + [(and (hpat:seq? a) (hpat:seq? b)) + (pattern-equal? (hpat:seq-inner a) (hpat:seq-inner b))] + ;; --- + [(and (ehpat? a) (ehpat? b)) + (and (equal? (ehpat-repc a) #f) + (equal? (ehpat-repc b) #f) + (pattern-equal? (ehpat-head a) (ehpat-head b)))] + ;; FIXME: more? + [else #f])) + (when DEBUG-OPT-FAIL + (when (and (eq? result #f) + (equal? (syntax->datum #`#,a) (syntax->datum #`#,b))) + (eprintf "** pattern-equal? failed on ~e\n" a))) + result) + +(define (equal-iattrs? as bs) + (and (= (length as) (length bs)) + ;; assumes attrs in same order + (for/and ([aa (in-list as)] + [ba (in-list bs)]) + (and (bound-identifier=? (attr-name aa) (attr-name ba)) + (equal? (attr-depth aa) (attr-depth ba)) + (equal? (attr-syntax? aa) (attr-syntax? ba)))))) + +(define (expr-equal? a b) + ;; Expression equality is undecidable in general. Especially difficult for unexpanded + ;; code, but it would be very difficult to set up correct env for local-expand because of + ;; attr binding rules. So, do *very* conservative approx: simple variables and literals. + ;; FIXME: any other common cases? + (cond [(not (and (syntax? a) (syntax? b))) + (equal? a b)] + [(and (identifier? a) (identifier? b)) + ;; note: "vars" might be identifier macros (unsafe to consider equal), + ;; so check var has no compile-time binding + (and (free-identifier=? a b) + (let/ec k (syntax-local-value a (lambda () (k #t))) #f))] + [(syntax-case (list a b) (quote) + [((quote ad) (quote bd)) + (cons (syntax->datum #'ad) (syntax->datum #'bd))] + [_ #f]) + => (lambda (ad+bd) + (equal? (car ad+bd) (cdr ad+bd)))] + [else + ;; approx: equal? only if both simple data (bool, string, etc), no inner stx + (let ([ad (syntax-e a)] + [bd (syntax-e b)]) + (and (equal? ad bd) + (free-identifier=? (datum->syntax a '#%datum) #'#%datum) + (free-identifier=? (datum->syntax b '#%datum) #'#%datum)))])) + +(define (equal-argu? a b) + (define (unwrap-arguments x) + (match x + [(arguments pargs kws kwargs) + (values pargs kws kwargs)])) + (define (list-equal? as bs inner-equal?) + (and (= (length as) (length bs)) + (andmap inner-equal? as bs))) + (let-values ([(apargs akws akwargs) (unwrap-arguments a)] + [(bpargs bkws bkwargs) (unwrap-arguments b)]) + (and (list-equal? apargs bpargs expr-equal?) + (equal? akws bkws) + (list-equal? akwargs bkwargs expr-equal?)))) + +(define (free-id/f-equal? a b) + (or (and (eq? a #f) + (eq? b #f)) + (and (identifier? a) + (identifier? b) + (free-identifier=? a b)))) + +(define (make-and-pattern subs) + (cond [(null? subs) (create-pat:any)] ;; shouldn't happen + [(null? (cdr subs)) (car subs)] + [else (create-pat:and subs)])) + +(define (*append a b) (if (null? b) a (append a b))) + +(define (stx-e x) (if (syntax? x) (syntax-e x) x)) + +;; ---- + +#| +(define (matrix->sexpr rows) + (cond [(null? rows) ;; shouldn't happen + '(FAIL)] + [(null? (cdr rows)) + (pk->sexpr (car rows))] + [else + (cons 'TRY (map pk->sexpr rows))])) +(define (pk->sexpr pk) + (match pk + [(pk1 pats k) + (cons 'MATCH (map pattern->sexpr pats))] + [(pk/same pat inner) + (list 'SAME (pattern->sexpr pat) (matrix->sexpr inner))] + [(pk/pair inner) + (list 'PAIR (matrix->sexpr inner))] + [(pk/and inner) + (list 'AND (matrix->sexpr inner))])) +(define (pattern->sexpr p) + (match p + [(pat:any _as) '_] + [(pat:integrated _as name pred desc _) + (format-symbol "~a:~a" (or name '_) desc)] + [(pat:var _as name parser _ _ _ _ _) + (cond [(and parser (regexp-match #rx"^parse-(.*)$" (symbol->string (syntax-e parser)))) + => (lambda (m) + (format-symbol "~a:~a" (or name '_) (cadr m)))] + [else + (if name (syntax-e name) '_)])] + [(? pat:literal?) `(quote ,(syntax->datum (pat:literal-id p)))] + [(pat:datum _as datum) datum] + [(? pat:action?) 'ACTION] + [(pat:pair _as head tail) + (cons (pattern->sexpr head) (pattern->sexpr tail))] + [(pat:head _as head tail) + (cons (pattern->sexpr head) (pattern->sexpr tail))] + [_ 'PATTERN])) +|# diff --git a/collects/syntax/parse/private/parse.rkt b/collects/syntax/parse/private/parse.rkt index 1e64e61576..18c7857c1f 100644 --- a/collects/syntax/parse/private/parse.rkt +++ b/collects/syntax/parse/private/parse.rkt @@ -10,6 +10,7 @@ "rep-patterns.rkt" "rep.rkt" "kws.rkt" + "opt.rkt" "txlift.rkt") "keywords.rkt" racket/syntax @@ -22,13 +23,6 @@ ;; ============================================================ -(begin-for-syntax - ;; controls debugging output for optimization successes and failures - (define DEBUG-OPT-SUCCEED #f) - (define DEBUG-OPT-FAIL #f)) - -;; ============================================================ - (provide define-syntax-class define-splicing-syntax-class define-integrable-syntax-class @@ -88,23 +82,72 @@ (define-syntax (parser/rhs stx) (syntax-case stx () - [(parser/rhs name formals attrs rhss splicing? ctx) + [(parser/rhs name formals relsattrs rhss splicing? ctx) (with-disappeared-uses - (let ([rhs - (parameterize ((current-syntax-context #'ctx)) - (parse-rhs #'rhss (syntax->datum #'attrs) (syntax-e #'splicing?) - #:context #'ctx))]) - #`(parser/rhs/parsed name formals attrs - #,rhs #,(and (rhs-description rhs) #t) - splicing? ctx)))])) - -(define-syntax (parser/rhs/parsed stx) - (syntax-case stx () - [(prp name formals attrs rhs rhs-has-description? splicing? ctx) - #`(parse:rhs rhs attrs formals splicing? - (if 'rhs-has-description? - #,(rhs-description (syntax-e #'rhs)) - (symbol->string 'name)))])) + (let () + (define the-rhs + (parameterize ((current-syntax-context #'ctx)) + (parse-rhs #'rhss (syntax->datum #'relsattrs) (syntax-e #'splicing?) + #:context #'ctx))) + (define-values (transparent? description variants defs commit? delimit-cut?) + (match the-rhs + [(rhs _ _ transparent? description variants defs (options commit? delimit-cut?) _) + (values transparent? description variants defs commit? delimit-cut?)])) + (define vdefss (map variant-definitions variants)) + (define formals* (rewrite-formals #'formals #'x #'rl)) + (define body + (cond [(null? variants) + #'(fail (failure pr es))] + [(syntax-e #'splicing?) + (with-syntax ([(alternative ...) + (for/list ([variant (in-list variants)]) + (define pattern (variant-pattern variant)) + (with-syntax ([pattern pattern] + [iattrs (pattern-attrs pattern)] + [commit? commit?] + [result-pr + (if transparent? + #'rest-pr + #'(ps-pop-opaque rest-pr))]) + #'(parse:H x cx rest-x rest-cx rest-pr pattern pr es + (variant-success relsattrs iattrs (rest-x rest-cx result-pr) + success cp0 commit?))))]) + #'(try alternative ...))] + [else + (with-syntax ([matrix + (optimize-matrix + (for/list ([variant (in-list variants)]) + (define pattern (variant-pattern variant)) + (with-syntax ([iattrs (pattern-attrs pattern)] + [commit? commit?]) + (pk1 (list pattern) + #'(variant-success relsattrs iattrs () + success cp0 commit?)))))]) + #'(parse:matrix ((x cx pr es)) matrix))])) + (with-syntax ([formals* formals*] + [(def ...) defs] + [((vdef ...) ...) vdefss] + [description (or description (symbol->string (syntax-e #'name)))] + [transparent? transparent?] + [delimit-cut? delimit-cut?] + [body body]) + #`(lambda (x cx pr es fh0 cp0 rl success . formals*) + (with ([this-syntax x] + [this-role rl]) + def ... + vdef ... ... + (#%expression + (syntax-parameterize ((this-context-syntax + (syntax-rules () + [(tbs) (ps-context-syntax pr)]))) + (let ([es (es-add-thing pr description 'transparent? rl es)] + [pr (if 'transparent? pr (ps-add-opaque pr))]) + (with ([fail-handler fh0] + [cut-prompt cp0]) + ;; Update the prompt, if required + ;; FIXME: can be optimized away if no cut exposed within variants + (with-maybe-delimit-cut delimit-cut? + body))))))))))])) (define-syntax (syntax-parse stx) (syntax-case stx () @@ -246,45 +289,23 @@ Conventions: - fh, cp, rl : id (var) |# -;; (parse:rhs rhs relsattrs formals splicing? expr) -;; : expr[stxclass-parser] -;; Takes a list of the relevant attrs; order is significant! -(define-syntax (parse:rhs stx) - (syntax-case stx () - [(parse:rhs #s(rhs _ _ transparent? _ variants (def ...) - #s(options commit? delimit-cut?) _integrate) - relsattrs formals splicing? description) - (with-syntax ([formals - (let loop ([fstx #'formals]) - (syntax-case fstx () - [([kw arg default] . more) - (keyword? (syntax-e #'kw)) - (cons #'(kw arg (with ([this-syntax x] [this-role rl]) default)) - (loop #'more))] - [([arg default] . more) - (not (keyword? (syntax-e #'kw))) - (cons #'(arg (with ([this-syntax x] [this-role rl]) default)) - (loop #'more))] - [(formal . more) - (cons #'formal (loop #'more))] - [_ fstx]))]) - #'(lambda (x cx pr es fh0 cp0 rl success . formals) - (with ([this-syntax x] - [this-role rl]) - def ... - (#%expression - (syntax-parameterize ((this-context-syntax - (syntax-rules () - [(tbs) (ps-context-syntax pr)]))) - (let ([es (es-add-thing pr description 'transparent? rl es)] - [pr (if 'transparent? pr (ps-add-opaque pr))]) - (with ([fail-handler fh0] - [cut-prompt cp0]) - ;; Update the prompt, if required - ;; FIXME: can be optimized away if no cut immediately within variants... - (with-maybe-delimit-cut delimit-cut? - (parse:variants x cx relsattrs variants splicing? transparent? - pr es success cp0 commit?)))))))))])) +(begin-for-syntax + (define (rewrite-formals fstx x-id rl-id) + (with-syntax ([x x-id] + [rl rl-id]) + (let loop ([fstx fstx]) + (syntax-case fstx () + [([kw arg default] . more) + (keyword? (syntax-e #'kw)) + (cons #'(kw arg (with ([this-syntax x] [this-role rl]) default)) + (loop #'more))] + [([arg default] . more) + (not (keyword? (syntax-e #'kw))) + (cons #'(arg (with ([this-syntax x] [this-role rl]) default)) + (loop #'more))] + [(formal . more) + (cons #'formal (loop #'more))] + [_ fstx]))))) ;; (with-maybe-delimit-cut bool expr) (define-syntax with-maybe-delimit-cut @@ -294,46 +315,12 @@ Conventions: [(wmdc #f k) k])) -;; (parse:variants x cx relsattrs variants splicing? pr es success cp0) : expr[Ans] -(define-syntax (parse:variants stx) - (syntax-case stx () - [(parse:variants x cx relsattrs () splicing? transparent? - pr es success cp0 commit?) - ;; Special case: no variants - #'(fail (failure pr es))] - [(parse:variants x cx relsattrs (variant ...) #t transparent? - pr es success cp0 commit?) - (with-syntax ([(#s(variant _ _ pattern (def ...)) ...) #'(variant ...)]) - #'(let () - def ... ... - (try (parse:H x cx rest-x rest-cx rest-pr pattern pr es - (variant-success relsattrs variant - (rest-x - rest-cx - (if 'transparent? rest-pr (ps-pop-opaque rest-pr))) - success cp0 commit?)) - ...)))] - [(parse:variants x cx relsattrs (variant ...) splicing? transparent? - pr es success cp0 commit?) - (with-syntax ([(#s(variant _ _ pattern (def ...)) ...) #'(variant ...)]) - #'(let () - def ... ... - (parse:S* ((x cx pr es)) - ((pattern) ...) - ((variant-success relsattrs variant - () - success cp0 commit?) - ...))))])) - ;; (variant-success relsattrs variant (also:id ...) success bool) : expr[Ans] (define-syntax (variant-success stx) (syntax-case stx () - [(variant-success relsattrs #s(variant _ _ pattern _) (also ...) success cp0 commit?) + [(variant-success relsattrs iattrs (also ...) success cp0 commit?) #`(with-maybe-reset-fail commit? cp0 - (base-success-expr #,(pattern-attrs (wash #'pattern)) - relsattrs - (also ...) - success))])) + (base-success-expr iattrs relsattrs (also ...) success))])) ;; (with-maybe-reset-fail bool id expr) (define-syntax with-maybe-reset-fail @@ -415,9 +402,12 @@ Conventions: (with ([fail-handler fh0] [cut-prompt fh0]) #,(cond [(pair? patterns) - (with-syntax ([(pattern ...) patterns] - [(body ...) body-exprs]) - #'(parse:S* ((x cx pr es)) ((pattern) ...) (body ...))) + (with-syntax ([matrix + (optimize-matrix + (for/list ([pattern (in-list patterns)] + [body-expr (in-list body-exprs)]) + (pk1 (list pattern) body-expr)))]) + #'(parse:matrix ((x cx pr es)) matrix)) #| (with-syntax ([(alternative ...) (for/list ([pattern (in-list patterns)] @@ -430,368 +420,42 @@ Conventions: ;; ---- -;; (parse:S* ((x cx pr es) ...) ((S-pattern ...) ...) (k ...)) : expr[Ans] -;; In k: attrs(S-pattern) are bound. - -;; (parse:S* (in1 ... inN) ((P11 ... P1N) ... (PM1 ... PMN)) (e1 ... eM)) -;; or equivalently (parse:S* (in1 ... inN) (row1 ... rowM) (e1 ... eM)) +;; (parse:matrix ((x cx pr es) ...) (PK ...)) : expr[Ans] +;; (parse:matrix (in1 ... inN) (#s(pk1 (P11 ... P1N) e1) ... #s(pk1 (PM1 ... PMN) eM))) ;; represents the matching matrix ;; [_in1_..._inN_|____] ;; [ P11 ... P1N | e1 ] ;; [ ⋮ ⋮ | ⋮ ] ;; [ PM1 ... PMN | eM ] -;; Can factor pattern P given clauses like -;; [ P P1 ... | e1] [ | [P1 ... | e1] ] -;; [ P ⋮ | ⋮] => [P | [ ⋮ | ⋮] ] - ; [ P PN ... | eN] [ | [PN ... | eN] ] -;; if -;; - P cannot cut -;; - P must succeed at most once (otherwise may reorder backtracking) - -;; Can unfold pair patterns as follows: -;; [ (P11 . P12) P1 ... | e1 ] [ P11 P12 P1 ... | e1 ] -;; [ ⋮ ⋮ | ⋮ ] => check pair, [ ⋮ | ⋮ ] -;; [ (PN1 . PN2) PN ... | eN ] [ PN1 PN2 PN ... | eN ] - -;; Can unfold ~and patterns similarly; ~and-patterns can hide -;; factoring opportunities. - -(define-syntax (parse:S* stx) +(define-syntax (parse:matrix stx) (syntax-case stx () - [(parse:S* () (() ...) (k ...)) - #'(try k ...)] - [(parse:S* ins rows ks) - ;; Split into uniform sequences of rows according to pattern in column1 - (let ([ins (syntax->list #'ins)] - [rows (map syntax->list (syntax->list #'rows))] - [ks (syntax->list #'ks)]) - (let-values ([(ins rows) (unfold-and-patterns ins rows)]) - (with-syntax ([ins ins] - [((parser sub-rows sub-ks) ...) (split-S* rows ks)]) - #'(try (parser ins sub-rows sub-ks) ...))))])) + [(parse:matrix ins (pk ...)) + #'(try (parse:pk ins pk) ...)])) -(define-syntax (parse:S*/pairs stx) +(define-syntax (parse:pk stx) (syntax-case stx () - [(parse:S*/pairs ins rows ks) - ;; First pattern in each row is pat:pair - (with-syntax ([((#s(pat:pair _ head tail) . row) ...) #'rows] - [((x cx pr es) . ins) #'ins]) - (when DEBUG-OPT-SUCCEED - (when (> (length (syntax->list #'rows)) 1) - (eprintf "** pairs\n"))) - #'(let-values ([(datum tcx) - (if (syntax? x) - (values (syntax-e x) x) - (values x cx))]) - (if (pair? datum) - (let ([hx (car datum)] - [hcx (car datum)] - [hpr (ps-add-car pr)] - [tx (cdr datum)] - [tpr (ps-add-cdr pr)]) - (parse:S* ((hx hcx hpr es) (tx tcx tpr es) . ins) - ((head tail . row) ...) - ks)) - (fail (failure pr es)))))])) - -(define-syntax (parse:S*/same stx) - (syntax-case stx () - [(parse:S*/same ins rows ks) - ;; First pattern in each row is same - (with-syntax ([((pat1 . row) ...) #'rows] - [((x cx pr es) . ins) #'ins]) - (with-syntax ([pat1 (stx-car #'(pat1 ...))]) - (when DEBUG-OPT-SUCCEED - (when (> (length (syntax->list #'rows)) 1) - (eprintf "** same: ~e\n" (syntax->datum #'pat1)))) - #'(parse:S x cx pat1 pr es (parse:S* ins (row ...) ks))))])) - -(begin-for-syntax - - (define (unfold-and-patterns ins rows) - ;; unfold-and : pattern (listof pattern) -> (values pattern (listof pattern)) - (define (unfold-and p onto) - (match (stx-e p) - [(pat:and _as subpatterns) - ;; pat:and is worth unfolding if first subpattern is not pat:action - (let* ([subpatterns (syntax->list subpatterns)] - [first-sub (car subpatterns)] - [rest-subs (cdr subpatterns)]) - (cond [(not (pat:action? (stx-e first-sub))) - (when #f ;; DEBUG-OPT-SUCCEED - (eprintf ">> unfolding: ~e\n" (syntax->datum p))) - (unfold-and first-sub - (*append rest-subs onto))] - [else (values p onto)]))] - [_ (values p onto)])) - (define (*append a b) (if (null? b) a (append a b))) - (define (make-and-pattern subs) - (cond [(null? subs) (create-pat:any)] ;; shouldn't happen - [(null? (cdr subs)) (car subs)] - [else - (let ([attrs 'unused]) ;; NOTE: attrs unused at this point, and it's a pain to recalc - (make-pat:and attrs subs))])) - (let-values ([(col1 col2) - (for/lists (col1 col2) ([row (in-list rows)]) - (unfold-and (car row) null))]) - (cond [(ormap pair? col2) - (values (cons (car ins) ins) - (for/list ([row (in-list rows)] - [col1 (in-list col1)] - [col2 (in-list col2)]) - (list* col1 (make-and-pattern col2) (cdr row))))] - [else (values ins rows)]))) - - (define (split-S* rows ks) - (cond [(null? rows) - null] - [else - (define row1 (stx->list (car rows))) - (define pat1 (car row1)) - (define k1 (car ks)) - ;; Now accumulate rows starting with patterns like pat1 - (define-values (parser keep?) (like-S-pattern? pat1)) - (let loop ([rows (cdr rows)] [ks (cdr ks)] [rrows (list row1)] [rks (list k1)]) - (cond [(null? rows) - (cons (list parser (reverse rrows) (reverse rks)) - (split-S* rows ks))] - [else - (define row1 (stx->list (car rows))) - (define pat1 (car row1)) - (define k1 (car ks)) - (cond [(keep? pat1) - (loop (cdr rows) (cdr ks) (cons row1 rrows) (cons k1 rks))] - [else - (cons (list parser (reverse rrows) (reverse rks)) - (split-S* rows ks))])]))])) - - (define (like-S-pattern? pat1) - (syntax-case pat1 () - [#s(pat:pair attrs head tail) - (values #'parse:S*/pairs - (lambda (x) (syntax-case x () - [#s(pat:pair _ _ _) #t] - [_ #f])))] - ;; FIXME: more? - [_ - (values #'parse:S*/same - ;; Can collapse only if no cut, succeed once, - ;; otherwise cannot collapse. - (if (pattern-factorable? pat1) - (lambda (pat2) - (pattern-equal? pat1 pat2)) - (lambda (pat2) - (when DEBUG-OPT-FAIL - (when (pattern-equal? pat1 pat2) - (eprintf "** cannot factor out ~e\n" (syntax->datum pat2)))) - #f)))])) - - (define (pattern-factorable? p) - ;; Can factor out p if p can succeed at most once, does not cut - ;; - if p can succeed multiple times, then factoring changes success order - ;; - if p can cut, then factoring changes which choice points are discarded (too few) - (let ([p (stx-e p)]) - (match p - [(pat:any _as) #t] - [(pat:var _as _n _p _argu _na _ac commit? _r) - ;; commit? implies delimit-cut - (eq? (stx-e commit?) #t)] - [(? pat:integrated?) #t] - [(pat:literal _as _lit _ip _lp) #t] - [(pat:datum _as _datum) #t] - [(pat:action _as _act _pat) #f] - [(pat:head _as head tail) - (and (pattern-factorable? head) - (pattern-factorable? tail))] - [(pat:dots _as heads tail) - (let ([heads (syntax->list heads)]) - ;; Conservative approximation for common case: one head pattern - ;; In general, check if heads don't overlap, don't overlap with tail. - (and (= (length heads) 1) - (let ([head (car heads)]) - (and (pattern-factorable? head))) - (equal? (syntax->datum tail) - (create-pat:datum '()))))] - [(pat:and _as patterns) - (andmap pattern-factorable? - (syntax->list patterns))] - [(pat:or _as patterns) #f] - [(pat:not _as pattern) #f] ;; FIXME: ? - [(pat:pair _as head tail) - (and (pattern-factorable? head) - (pattern-factorable? tail))] - [(pat:vector _as pattern) - (pattern-factorable? pattern)] - [(pat:box _as pattern) - (pattern-factorable? pattern)] - [(pat:pstruct _as key pattern) - (pattern-factorable? pattern)] - [(pat:describe _as pattern _desc _trans _role) - (pattern-factorable? pattern)] - [(pat:delimit _as pattern) - (pattern-factorable? pattern)] - [(pat:commit _as pattern) #t] - [(? pat:reflect?) #f] - [(pat:post _as pattern) - (pattern-factorable? pattern)] - ;; ---- - [(hpat:var _as _name _parser _argu _na _ac commit? _role) - (eq? (stx-e commit?) #t)] - [(hpat:seq _as inner) - (pattern-factorable? inner)] - [(hpat:commit _as inner) #t] - ;; ---- - [(ehpat _as head repc) - (and (equal? (syntax->datum repc) #f) - (pattern-factorable? head))] - ;; ---- - [else #f]))) - - (define (pattern-equal? a b) - (define (subpatterns-equal? as bs) - (let ([as (stx->list as)] - [bs (stx->list bs)]) - (and (= (length as) (length bs)) - (for/and ([a (in-list as)] - [b (in-list bs)]) - (pattern-equal? a b))))) - (define result - (let ([a (stx-e a)] - [b (stx-e b)]) - (cond [(and (pat:any? a) (pat:any? b)) #t] - [(and (pat:var? a) (pat:var? b)) - (and (free-id/f-equal? (pat:var-parser a) (pat:var-parser b)) - (equal-iattrs? (pat:var-attrs a) (pat:var-attrs b)) - (equal-argu? (pat:var-argu a) (pat:var-argu b)) - (expr-equal? (pat:var-role a) (pat:var-role b)))] - [(and (pat:integrated? a) (pat:integrated? b)) - (and (free-identifier=? (pat:integrated-predicate a) - (pat:integrated-predicate b)) - (equal-iattrs? (pat:integrated-attrs a) - (pat:integrated-attrs b)) - (expr-equal? (pat:integrated-role a) (pat:integrated-role b)))] - [(and (pat:literal? a) (pat:literal? b)) - ;; literals are hard to compare, so compare gensyms attached to - ;; literal ids (see rep.rkt) instead - (let ([ka (syntax-property (pat:literal-id a) 'literal)] - [kb (syntax-property (pat:literal-id b) 'literal)]) - (and ka kb (eq? ka kb)))] - [(and (pat:datum? a) (pat:datum? b)) - (equal? (syntax->datum (pat:datum-datum a)) - (syntax->datum (pat:datum-datum b)))] - [(and (pat:head? a) (pat:head? b)) - (and (pattern-equal? (pat:head-head a) (pat:head-head b)) - (pattern-equal? (pat:head-tail a) (pat:head-tail b)))] - [(and (pat:dots? a) (pat:dots? b)) - (and (subpatterns-equal? (pat:dots-heads a) (pat:dots-heads b)) - (pattern-equal? (pat:dots-tail a) (pat:dots-tail b)))] - [(and (pat:and? a) (pat:and? b)) - (subpatterns-equal? (pat:and-patterns a) (pat:and-patterns b))] - [(and (pat:or? a) (pat:or? b)) - (subpatterns-equal? (pat:or-patterns a) (pat:or-patterns b))] - [(and (pat:not? a) (pat:not? b)) - (pattern-equal? (pat:not-pattern a) (pat:not-pattern b))] - [(and (pat:pair? a) (pat:pair? b)) - (and (pattern-equal? (pat:pair-head a) (pat:pair-head b)) - (pattern-equal? (pat:pair-tail a) (pat:pair-tail b)))] - [(and (pat:vector? a) (pat:vector? b)) - (pattern-equal? (pat:vector-pattern a) (pat:vector-pattern b))] - [(and (pat:box? a) (pat:box? b)) - (pattern-equal? (pat:box-pattern a) (pat:box-pattern b))] - [(and (pat:pstruct? a) (pat:pstruct? b)) - (and (equal? (syntax->datum (pat:pstruct-key a)) - (syntax->datum (pat:pstruct-key b))) - (pattern-equal? (pat:pstruct-pattern a) - (pat:pstruct-pattern b)))] - [(and (pat:describe? a) (pat:describe? b)) #f] ;; can't compare desc exprs - [(and (pat:delimit? a) (pat:delimit? b)) - (pattern-equal? (pat:delimit-pattern a) (pat:delimit-pattern b))] - [(and (pat:commit? a) (pat:commit? b)) - (pattern-equal? (pat:commit-pattern a) (pat:commit-pattern b))] - [(and (pat:reflect? a) (pat:reflect? b)) #f] ;; FIXME: ? - [(and (pat:post? a) (pat:post? b)) - (pattern-equal? (pat:post-pattern a) (pat:post-pattern b))] - ;; --- - [(and (hpat:var? a) (hpat:var? b)) - (and (free-id/f-equal? (hpat:var-parser a) (hpat:var-parser b)) - (equal-iattrs? (hpat:var-attrs a) (hpat:var-attrs b)) - (equal-argu? (hpat:var-argu a) (hpat:var-argu b)) - (expr-equal? (hpat:var-role a) (hpat:var-role b)))] - [(and (hpat:seq? a) (hpat:seq? b)) - (pattern-equal? (hpat:seq-inner a) (hpat:seq-inner b))] - ;; --- - [(and (ehpat? a) (ehpat? b)) - (and (equal? (syntax->datum (ehpat-repc a)) #f) - (equal? (syntax->datum (ehpat-repc b)) #f) - (pattern-equal? (ehpat-head a) (ehpat-head b)))] - ;; FIXME: more? - [else #f]))) - (when DEBUG-OPT-FAIL - (when (and (equal? (syntax->datum a) (syntax->datum b)) - (eq? result #f)) - (eprintf "** pattern-equal? failed on ~e\n" (syntax->datum a)))) - result) - - (define (equal-iattrs? as bs) - (let ([as (wash-iattrs as)] - [bs (wash-iattrs bs)]) - (and (= (length as) (length bs)) - ;; assumes attrs in same order - (for/and ([aa (in-list (wash-iattrs as))] - [ba (in-list (wash-iattrs bs))]) - (and (bound-identifier=? (attr-name aa) (attr-name ba)) - (equal? (attr-depth aa) (attr-depth ba)) - (equal? (attr-syntax? aa) (attr-syntax? ba))))))) - - (define (expr-equal? a b) - ;; Expression equality is undecidable in general. Especially difficult for unexpanded - ;; code, but it would be very difficult to set up correct env for local-expand because of - ;; attr binding rules. So, do *very* conservative approx: simple variables and literals. - ;; FIXME: any other common cases? - (cond [(and (identifier? a) (identifier? b)) - ;; note: "vars" might be identifier macros (unsafe to consider equal), - ;; so check var has no compile-time binding - (and (free-identifier=? a b) - (let/ec k (syntax-local-value a (lambda () (k #t))) #f))] - [(syntax-case (list a b) (quote) - [((quote ad) (quote bd)) - (cons (syntax->datum #'ad) (syntax->datum #'bd))] - [_ #f]) - => (lambda (ad+bd) - (equal? (car ad+bd) (cdr ad+bd)))] - [else - ;; approx: equal? only if both simple data (bool, string, etc), no inner stx - (let ([ad (syntax-e a)] - [bd (syntax-e b)]) - (and (equal? ad bd) - (free-identifier=? (datum->syntax a '#%datum) #'#%datum) - (free-identifier=? (datum->syntax b '#%datum) #'#%datum)))])) - - (define (equal-argu? a b) - (define (unwrap-arguments x) - (match (stx-e x) - [(arguments pargs kws kwargs) - (values (syntax->list pargs) - (syntax->datum kws) - (syntax->list kwargs))])) - (define (list-equal? as bs inner-equal?) - (and (= (length as) (length bs)) - (andmap inner-equal? as bs))) - (let-values ([(apargs akws akwargs) (unwrap-arguments a)] - [(bpargs bkws bkwargs) (unwrap-arguments b)]) - (and (list-equal? apargs bpargs expr-equal?) - (equal? akws bkws) - (list-equal? akwargs bkwargs expr-equal?)))) - - (define (free-id/f-equal? a b) - (or (and (eq? (syntax-e a) #f) - (eq? (syntax-e b) #f)) - (and (identifier? a) - (identifier? b) - (free-identifier=? a b)))) - - (define (stx-e x) (if (syntax? x) (syntax-e x) x))) + [(parse:pk () #s(pk1 () k)) + #'k] + [(parse:pk ((x cx pr es) . ins) #s(pk1 (pat1 . pats) k)) + #'(parse:S x cx pat1 pr es (parse:pk ins #s(pk1 pats k)))] + [(parse:pk ((x cx pr es) . ins) #s(pk/same pat1 inner)) + #'(parse:S x cx pat1 pr es (parse:matrix ins inner))] + [(parse:pk ((x cx pr es) . ins) #s(pk/pair inner)) + #'(let-values ([(datum tcx) + (if (syntax? x) + (values (syntax-e x) x) + (values x cx))]) + (if (pair? datum) + (let ([hx (car datum)] + [hcx (car datum)] + [hpr (ps-add-car pr)] + [tx (cdr datum)] + [tpr (ps-add-cdr pr)]) + (parse:matrix ((hx hcx hpr es) (tx tcx tpr es) . ins) inner)) + (fail (failure pr es))))] + [(parse:pk (in1 . ins) #s(pk/and inner)) + #'(parse:matrix (in1 in1 . ins) inner)])) ;; ----