From 1c01df60ce11fc1a68c06653594964254bbfcd9a Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 4 Jan 2017 22:11:08 -0500 Subject: [PATCH] syntax/parse: use logging instead of conditional eprintf, show more patterns --- racket/collects/syntax/parse/private/opt.rkt | 91 ++++++++++++------- .../syntax/parse/private/residual-ct.rkt | 1 + 2 files changed, 59 insertions(+), 33 deletions(-) diff --git a/racket/collects/syntax/parse/private/opt.rkt b/racket/collects/syntax/parse/private/opt.rkt index 2119af7aa8..b3b6556819 100644 --- a/racket/collects/syntax/parse/private/opt.rkt +++ b/racket/collects/syntax/parse/private/opt.rkt @@ -8,10 +8,6 @@ (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 @@ -75,18 +71,17 @@ (define (optimize-matrix0 rows) (define now (current-inexact-milliseconds)) - (when (and DEBUG-OPT-SUCCEED (> (length rows) 1)) - (eprintf "\n%% optimizing (~s):\n" (length rows)) - (pretty-write (matrix->sexpr rows) (current-error-port))) + (when (and (> (length rows) 1)) + (log-syntax-parse-debug "OPT matrix (~s rows)\n~a" (length rows) + (pretty-format (matrix->sexpr rows) #:mode 'print))) (define result (optimize-matrix rows)) (define then (current-inexact-milliseconds)) - (when (and DEBUG-OPT-SUCCEED (> (length rows) 1)) + (when (and (> (length rows) 1)) (cond [(= (length result) (length rows)) - (eprintf "%% !! FAILED !! (~s ms)\n\n" (floor (- then now)))] + (log-syntax-parse-debug "OPT FAILED (~s ms)" (floor (- then now)))] [else - (eprintf "==> (~s ms)\n" (floor (- then now))) - (pretty-write (matrix->sexpr result) (current-error-port)) - (eprintf "\n")])) + (log-syntax-parse-debug "OPT ==> (~s ms)\n~a" (floor (- then now)) + (pretty-format (matrix->sexpr result) #:mode 'print))])) result) ;; optimize-matrix : (listof pk1) -> Matrix @@ -140,8 +135,7 @@ [(pat:pair head tail) (values (lambda (p) (pat:pair? p)) (lambda (rows) - (when DEBUG-OPT-SUCCEED - (eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1))) + (log-syntax-parse-debug "-- got ~s pair rows like ~e" (length rows) (pattern->sexpr pat1)) (cond [(> (length rows) 1) (pk/pair (optimize-matrix (for/list ([row (in-list rows)]) @@ -155,8 +149,7 @@ [(? pattern-factorable?) (values (lambda (pat2) (pattern-equal? pat1 pat2)) (lambda (rows) - (when DEBUG-OPT-SUCCEED - (eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1))) + (log-syntax-parse-debug "-- got ~s factorable like ~e" (length rows) (pattern->sexpr pat1)) (cond [(> (length rows) 1) (pk/same pat1 (optimize-matrix @@ -164,11 +157,7 @@ (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) + (values (lambda (pat2) #f) (lambda (rows) ;; (length rows) = 1 (car rows)))])) @@ -182,8 +171,6 @@ (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)])) @@ -331,10 +318,10 @@ (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))) + (when (and (log-level? syntax-parse-logger 'debug) + (eq? result #f) + (equal? (syntax->datum #`#,a) (syntax->datum #`#,b))) + (log-syntax-parse-debug "** pattern-equal? failed on ~e" a)) result) (define (equal-iattrs? as bs) @@ -441,15 +428,53 @@ (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 datum) datum] - [(? pat:action?) 'ACTION] + [(? pat:literal?) `(syntax ,(syntax->datum (pat:literal-id p)))] + [(pat:datum datum) + (cond [(or (symbol? datum) (pair? datum)) + `(quote ,datum)] + [else datum])] + [(pat:action action (pat:any)) (pattern->sexpr action)] + [(pat:action action inner) (list '~AAND (pattern->sexpr action) (pattern->sexpr inner))] + [(pat:and patterns) (cons '~and (map pattern->sexpr patterns))] + [(pat:or _ patterns _) (cons '~or (map pattern->sexpr patterns))] + [(pat:not pattern) (list '~not (pattern->sexpr pattern))] [(pat:pair head tail) (cons (pattern->sexpr head) (pattern->sexpr tail))] [(pat:head head tail) (cons (pattern->sexpr head) (pattern->sexpr tail))] [(pat:dots (list eh) tail) (list* (pattern->sexpr eh) '... (pattern->sexpr tail))] - [(ehpat _as hpat '#f _cn) - (pattern->sexpr hpat)] - [_ 'PATTERN])) + [(pat:dots ehs tail) + (list* (cons '~alt (map pattern->sexpr ehs)) '... (pattern->sexpr tail))] + [(pat:describe sp _ _ _) (list '~describe (pattern->sexpr sp))] + [(pat:delimit sp) (list '~delimit-cut (pattern->sexpr sp))] + [(pat:commit sp) (list '~commit (pattern->sexpr sp))] + [(pat:ord pattern _ _) (list '~ord (pattern->sexpr pattern))] + [(pat:post sp) (list '~post (pattern->sexpr sp))] + [(action:cut) '~!] + [(action:fail cnd msg) (list '~fail)] + [(action:bind attr expr) (list '~bind)] + [(action:and as) (cons '~and (map pattern->sexpr as))] + [(action:parse sp expr) (list '~parse (pattern->sexpr sp))] + [(action:do stmts) (list '~do)] + [(action:undo stmts) (list '~undo)] + [(action:ord ap _ _) (list '~ord (pattern->sexpr ap))] + [(action:post ap) (list '~post (pattern->sexpr ap))] + [(hpat:var/p name parser _ _ _ _) + (cond [(and parser (regexp-match #rx"^parser-(.*)$" (symbol->string (syntax-e parser)))) + => (lambda (m) (format-symbol "~a:~a" (or name '_) (cadr m)))] + [else (if name (syntax-e name) '_)])] + [(hpat:seq lp) (cons '~seq (pattern->sexpr lp))] + [(hpat:action ap hp) (list '~AAND (pattern->sexpr ap) (pattern->sexpr hp))] + [(hpat:and hp sp) (list '~and (pattern->sexpr hp) (pattern->sexpr sp))] + [(hpat:or _ hps _) (cons '~or (map pattern->sexpr hps))] + [(hpat:describe hp _ _ _) (list '~describe (pattern->sexpr hp))] + [(hpat:delimit hp) (list '~delimit-cut (pattern->sexpr hp))] + [(hpat:commit hp) (list '~commit (pattern->sexpr hp))] + [(hpat:ord hp _ _) (list '~ord (pattern->sexpr hp))] + [(hpat:post hp) (list '~post (pattern->sexpr hp))] + [(hpat:peek hp) (list '~peek (pattern->sexpr hp))] + [(hpat:peek-not hp) (list '~peek-not (pattern->sexpr hp))] + [(ehpat _as hpat repc _cn) + (if (eq? repc #f) (pattern->sexpr hpat) (list '~REPC (pattern->sexpr hpat)))] + [_ '])) diff --git a/racket/collects/syntax/parse/private/residual-ct.rkt b/racket/collects/syntax/parse/private/residual-ct.rkt index fb1d1e5229..6110a984e8 100644 --- a/racket/collects/syntax/parse/private/residual-ct.rkt +++ b/racket/collects/syntax/parse/private/residual-ct.rkt @@ -19,6 +19,7 @@ log-syntax-parse-warning log-syntax-parse-info log-syntax-parse-debug + syntax-parse-logger prop:pattern-expander pattern-expander? pattern-expander-proc