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

syntax/parse: fix bug that disabled opt, improve debugging

Browse Source
This commit is contained in:
Ryan Culpepper 2016-03-23 10:09:53 -04:00
parent cf595678f6
commit 25b2ec2e03
2 changed files with 29 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -55,14 +55,19 @@
;; ---- ;; ----
(define (optimize-matrix0 rows) (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)))
(define result (optimize-matrix rows)) (define result (optimize-matrix rows))
#| (define then (current-inexact-milliseconds))
(when DEBUG-OPT-SUCCEED (when (and DEBUG-OPT-SUCCEED (> (length rows) 1))
(let ([sexpr (matrix->sexpr result)]) (cond [(= (length result) (length rows))
(unless (equal? (car sexpr) 'MATCH) (eprintf "%% !! FAILED !! (~s ms)\n\n" (floor (- then now)))]
(eprintf "%% optimized matrix (~s):\n" (length rows)) [else
(pretty-write (matrix->sexpr result) (current-error-port))))) (eprintf "==> (~s ms)\n" (floor (- then now)))
|# (pretty-write (matrix->sexpr result) (current-error-port))
(eprintf "\n")]))
result) result)
;; optimize-matrix : (listof pk1) -> Matrix ;; optimize-matrix : (listof pk1) -> Matrix
@ -113,12 +118,12 @@
;; pattern->partitioner : pattern -> (values (pattern -> boolean) ((listof pk1) -> PK)) ;; pattern->partitioner : pattern -> (values (pattern -> boolean) ((listof pk1) -> PK))
(define (pattern->partitioner pat1) (define (pattern->partitioner pat1)
(match pat1 (match pat1
[(pat:pair proper? attrs head tail) [(pat:pair attrs proper? head tail)
(values (lambda (p) (and (pat:pair? p) (eq? (pat:pair-proper? p) proper?))) (values (lambda (p) (and (pat:pair? p) (eq? (pat:pair-proper? p) proper?)))
(lambda (rows) (lambda (rows)
(cond [(> (length rows) 1)
(when DEBUG-OPT-SUCCEED (when DEBUG-OPT-SUCCEED
(eprintf "** pairs (~s)\n" (length rows))) (eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1)))
(cond [(> (length rows) 1)
(pk/pair proper? (pk/pair proper?
(optimize-matrix (optimize-matrix
(for/list ([row (in-list rows)]) (for/list ([row (in-list rows)])
@ -132,9 +137,9 @@
[(? pattern-factorable?) [(? pattern-factorable?)
(values (lambda (pat2) (pattern-equal? pat1 pat2)) (values (lambda (pat2) (pattern-equal? pat1 pat2))
(lambda (rows) (lambda (rows)
(cond [(> (length rows) 1)
(when DEBUG-OPT-SUCCEED (when DEBUG-OPT-SUCCEED
(eprintf "** factored(~s): ~e\n" (length rows) (syntax->datum #`#,pat1))) (eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1)))
(cond [(> (length rows) 1)
(pk/same pat1 (pk/same pat1
(optimize-matrix (optimize-matrix
(for/list ([row (in-list rows)]) (for/list ([row (in-list rows)])
@ -372,7 +377,6 @@
;; ---- ;; ----
#|
(define (matrix->sexpr rows) (define (matrix->sexpr rows)
(cond [(null? rows) ;; shouldn't happen (cond [(null? rows) ;; shouldn't happen
'(FAIL)] '(FAIL)]
@ -386,7 +390,7 @@
(cons 'MATCH (map pattern->sexpr pats))] (cons 'MATCH (map pattern->sexpr pats))]
[(pk/same pat inner) [(pk/same pat inner)
(list 'SAME (pattern->sexpr pat) (matrix->sexpr inner))] (list 'SAME (pattern->sexpr pat) (matrix->sexpr inner))]
[(pk/pair inner) [(pk/pair proper? inner)
(list 'PAIR (matrix->sexpr inner))] (list 'PAIR (matrix->sexpr inner))]
[(pk/and inner) [(pk/and inner)
(list 'AND (matrix->sexpr inner))])) (list 'AND (matrix->sexpr inner))]))
@ -404,9 +408,14 @@
[(? pat:literal?) `(quote ,(syntax->datum (pat:literal-id p)))] [(? pat:literal?) `(quote ,(syntax->datum (pat:literal-id p)))]
[(pat:datum _as datum) datum] [(pat:datum _as datum) datum]
[(? pat:action?) 'ACTION] [(? pat:action?) 'ACTION]
[(pat:pair _as _p? head tail) [(pat:pair _as '#t head tail)
(cons (pattern->sexpr head) (pattern->sexpr tail))] (cons (pattern->sexpr head) (pattern->sexpr tail))]
[(pat:pair _as '#f head tail)
(list '~pair (pattern->sexpr head) (pattern->sexpr tail))]
[(pat:head _as head tail) [(pat:head _as head tail)
(cons (pattern->sexpr head) (pattern->sexpr tail))] (cons (pattern->sexpr head) (pattern->sexpr tail))]
[(pat:dots _as (list eh) tail)
(list* (pattern->sexpr eh) '... (pattern->sexpr tail))]
[(ehpat _as hpat '#f)
(pattern->sexpr hpat)]
[_ 'PATTERN])) [_ 'PATTERN]))
|#

7
racket/collects/syntax/parse/private/parse.rkt
View File

@ -477,10 +477,11 @@ Conventions:
(define-syntax (first-desc:matrix stx) (define-syntax (first-desc:matrix stx)
(syntax-case stx () (syntax-case stx ()
[(fdm (#s(pk (pat1 . pats) k))) [(fdm (#s(pk1 (pat1 . pats) k)))
#'(first-desc:S pat1)] #'(first-desc:S pat1)]
[(fdm (pk ...)) [(fdm (#s(pk/same pat1 pks)))
;; FIXME #'(first-desc:S pat1)]
[(fdm (pk ...)) ;; FIXME
#'#f])) #'#f]))
;; ---- ;; ----