suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

syntax/parse: use logging instead of conditional eprintf, show more patterns

Browse Source
This commit is contained in:
Ryan Culpepper 2017-01-04 22:11:08 -05:00
parent 39bacd45d5
commit 1c01df60ce
2 changed files with 59 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
racket/collects/syntax/parse/private/opt.rkt
View File

@ -8,10 +8,6 @@
(provide (struct-out pk1) (provide (struct-out pk1)
(rename-out [optimize-matrix0 optimize-matrix])) (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 Matrix is a (listof PK) where each PK has same number of columns
@ -75,18 +71,17 @@
(define (optimize-matrix0 rows) (define (optimize-matrix0 rows)
(define now (current-inexact-milliseconds)) (define now (current-inexact-milliseconds))
(when (and DEBUG-OPT-SUCCEED (> (length rows) 1)) (when (and (> (length rows) 1))
(eprintf "\n%% optimizing (~s):\n" (length rows)) (log-syntax-parse-debug "OPT matrix (~s rows)\n~a" (length rows)
(pretty-write (matrix->sexpr rows) (current-error-port))) (pretty-format (matrix->sexpr rows) #:mode 'print)))
(define result (optimize-matrix rows)) (define result (optimize-matrix rows))
(define then (current-inexact-milliseconds)) (define then (current-inexact-milliseconds))
(when (and DEBUG-OPT-SUCCEED (> (length rows) 1)) (when (and (> (length rows) 1))
(cond [(= (length result) (length rows)) (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 [else
(eprintf "==> (~s ms)\n" (floor (- then now))) (log-syntax-parse-debug "OPT ==> (~s ms)\n~a" (floor (- then now))
(pretty-write (matrix->sexpr result) (current-error-port)) (pretty-format (matrix->sexpr result) #:mode 'print))]))
(eprintf "\n")]))
result) result)
;; optimize-matrix : (listof pk1) -> Matrix ;; optimize-matrix : (listof pk1) -> Matrix
@ -140,8 +135,7 @@
[(pat:pair head tail) [(pat:pair head tail)
(values (lambda (p) (pat:pair? p)) (values (lambda (p) (pat:pair? p))
(lambda (rows) (lambda (rows)
(when DEBUG-OPT-SUCCEED (log-syntax-parse-debug "-- got ~s pair rows like ~e" (length rows) (pattern->sexpr pat1))
(eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1)))
(cond [(> (length rows) 1) (cond [(> (length rows) 1)
(pk/pair (optimize-matrix (pk/pair (optimize-matrix
(for/list ([row (in-list rows)]) (for/list ([row (in-list rows)])
@ -155,8 +149,7 @@
[(? pattern-factorable?) [(? pattern-factorable?)
(values (lambda (pat2) (pattern-equal? pat1 pat2)) (values (lambda (pat2) (pattern-equal? pat1 pat2))
(lambda (rows) (lambda (rows)
(when DEBUG-OPT-SUCCEED (log-syntax-parse-debug "-- got ~s factorable like ~e" (length rows) (pattern->sexpr pat1))
(eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1)))
(cond [(> (length rows) 1) (cond [(> (length rows) 1)
(pk/same pat1 (pk/same pat1
(optimize-matrix (optimize-matrix
@ -164,11 +157,7 @@
(pk1 (cdr (pk1-patterns row)) (pk1-k row)))))] (pk1 (cdr (pk1-patterns row)) (pk1-k row)))))]
[else (car rows)])))] [else (car rows)])))]
[_ [_
(values (lambda (pat2) (values (lambda (pat2) #f)
(when DEBUG-OPT-FAIL
(when (pattern-equal? pat1 pat2)
(eprintf "** cannot factor: ~e\n" (syntax->datum #`#,pat2))))
#f)
(lambda (rows) (lambda (rows)
;; (length rows) = 1 ;; (length rows) = 1
(car rows)))])) (car rows)))]))
@ -182,8 +171,6 @@
(let* ([first-sub (car subpatterns)] (let* ([first-sub (car subpatterns)]
[rest-subs (cdr subpatterns)]) [rest-subs (cdr subpatterns)])
(cond [(not (pat:action? first-sub)) (cond [(not (pat:action? first-sub))
(when #f ;; DEBUG-OPT-SUCCEED
(eprintf ">> unfolding: ~e\n" p))
(unfold-and first-sub (*append rest-subs onto))] (unfold-and first-sub (*append rest-subs onto))]
[else (values p onto)]))] [else (values p onto)]))]
[_ (values p onto)])) [_ (values p onto)]))
@ -331,10 +318,10 @@
(pattern-equal? (ehpat-head a) (ehpat-head b)))] (pattern-equal? (ehpat-head a) (ehpat-head b)))]
;; FIXME: more? ;; FIXME: more?
[else #f])) [else #f]))
(when DEBUG-OPT-FAIL (when (and (log-level? syntax-parse-logger 'debug)
(when (and (eq? result #f) (eq? result #f)
(equal? (syntax->datum #`#,a) (syntax->datum #`#,b))) (equal? (syntax->datum #`#,a) (syntax->datum #`#,b)))
(eprintf "** pattern-equal? failed on ~e\n" a))) (log-syntax-parse-debug "** pattern-equal? failed on ~e" a))
result) result)
(define (equal-iattrs? as bs) (define (equal-iattrs? as bs)
@ -441,15 +428,53 @@
(format-symbol "~a:~a" (or name '_) (cadr m)))] (format-symbol "~a:~a" (or name '_) (cadr m)))]
[else [else
(if name (syntax-e name) '_)])] (if name (syntax-e name) '_)])]
[(? pat:literal?) `(quote ,(syntax->datum (pat:literal-id p)))] [(? pat:literal?) `(syntax ,(syntax->datum (pat:literal-id p)))]
[(pat:datum datum) datum] [(pat:datum datum)
[(? pat:action?) 'ACTION] (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) [(pat:pair head tail)
(cons (pattern->sexpr head) (pattern->sexpr tail))] (cons (pattern->sexpr head) (pattern->sexpr tail))]
[(pat:head head tail) [(pat:head head tail)
(cons (pattern->sexpr head) (pattern->sexpr tail))] (cons (pattern->sexpr head) (pattern->sexpr tail))]
[(pat:dots (list eh) tail) [(pat:dots (list eh) tail)
(list* (pattern->sexpr eh) '... (pattern->sexpr tail))] (list* (pattern->sexpr eh) '... (pattern->sexpr tail))]
[(ehpat _as hpat '#f _cn) [(pat:dots ehs tail)
(pattern->sexpr hpat)] (list* (cons '~alt (map pattern->sexpr ehs)) '... (pattern->sexpr tail))]
[_ 'PATTERN])) [(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)))]
[_ '<Pattern>]))

1
racket/collects/syntax/parse/private/residual-ct.rkt
View File

@ -19,6 +19,7 @@
log-syntax-parse-warning log-syntax-parse-warning
log-syntax-parse-info log-syntax-parse-info
log-syntax-parse-debug log-syntax-parse-debug
syntax-parse-logger
prop:pattern-expander prop:pattern-expander
pattern-expander? pattern-expander?
pattern-expander-proc pattern-expander-proc