opt.rkt (18049B)
1 #lang racket/base 2 (require racket/syntax 3 racket/pretty 4 syntax/parse/private/residual-ct ;; keep abs. path 5 syntax/parse/private/minimatch 6 syntax/parse/private/rep-patterns 7 syntax/parse/private/kws) 8 (provide (struct-out pk1) 9 (rename-out [optimize-matrix0 optimize-matrix])) 10 11 ;; controls debugging output for optimization successes and failures 12 (define DEBUG-OPT-SUCCEED #f) 13 (define DEBUG-OPT-FAIL #f) 14 15 ;; ---- 16 17 ;; A Matrix is a (listof PK) where each PK has same number of columns 18 ;; A PK is one of 19 ;; - (pk1 (listof pattern) expr) -- a simple row in a parsing matrix 20 ;; - (pk/same pattern Matrix) -- a submatrix with a common first column factored out 21 ;; - (pk/pair Matrix) -- a submatrix with pair patterns in the first column unfolded 22 ;; - (pk/and Matrix) -- a submatrix with and patterns in the first column unfolded 23 (struct pk1 (patterns k) #:prefab) 24 (struct pk/same (pattern inner) #:prefab) 25 (struct pk/pair (inner) #:prefab) 26 (struct pk/and (inner) #:prefab) 27 28 (define (pk-columns pk) 29 (match pk 30 [(pk1 patterns k) (length patterns)] 31 [(pk/same p inner) (add1 (pk-columns inner))] 32 [(pk/pair inner) (sub1 (pk-columns inner))] 33 [(pk/and inner) (sub1 (pk-columns inner))])) 34 35 ;; Can factor pattern P given clauses like 36 ;; [ P P1 ... | e1] [ | [P1 ... | e1] ] 37 ;; [ P ⋮ | ⋮] => [P | [ ⋮ | ⋮] ] 38 ; [ P PN ... | eN] [ | [PN ... | eN] ] 39 ;; if P cannot cut and P succeeds at most once (otherwise may reorder backtracking) 40 41 ;; Can unfold pair patterns as follows: 42 ;; [ (P11 . P12) P1 ... | e1 ] [ P11 P12 P1 ... | e1 ] 43 ;; [ ⋮ ⋮ | ⋮ ] => check pair, [ ⋮ | ⋮ ] 44 ;; [ (PN1 . PN2) PN ... | eN ] [ PN1 PN2 PN ... | eN ] 45 46 ;; Can unfold ~and patterns similarly; ~and patterns can hide 47 ;; factoring opportunities. 48 49 ;; ---- 50 51 (define (optimize-matrix0 rows) 52 (define now (current-inexact-milliseconds)) 53 (when (and DEBUG-OPT-SUCCEED (> (length rows) 1)) 54 (eprintf "\n%% optimizing (~s):\n" (length rows)) 55 (pretty-write (matrix->sexpr rows) (current-error-port))) 56 (define result (optimize-matrix rows)) 57 (define then (current-inexact-milliseconds)) 58 (when (and DEBUG-OPT-SUCCEED (> (length rows) 1)) 59 (cond [(= (length result) (length rows)) 60 (eprintf "%% !! FAILED !! (~s ms)\n\n" (floor (- then now)))] 61 [else 62 (eprintf "==> (~s ms)\n" (floor (- then now))) 63 (pretty-write (matrix->sexpr result) (current-error-port)) 64 (eprintf "\n")])) 65 result) 66 67 ;; optimize-matrix : (listof pk1) -> Matrix 68 (define (optimize-matrix rows) 69 (cond [(null? rows) null] 70 [(null? (cdr rows)) rows] ;; no opportunities for 1 row 71 [(null? (pk1-patterns (car rows))) rows] 72 [else 73 ;; first unfold and-patterns 74 (let-values ([(col1 col2) 75 (for/lists (col1 col2) ([row (in-list rows)]) 76 (unfold-and (car (pk1-patterns row)) null))]) 77 (cond [(ormap pair? col2) 78 (list 79 (pk/and 80 (optimize-matrix* 81 (for/list ([row (in-list rows)] 82 [col1 (in-list col1)] 83 [col2 (in-list col2)]) 84 (pk1 (list* col1 85 (make-and-pattern col2) 86 (cdr (pk1-patterns row))) 87 (pk1-k row))))))] 88 [else (optimize-matrix* rows)]))])) 89 90 ;; optimize-matrix* : (listof pk1) -> Matrix 91 ;; The matrix is nonempty, and first column has no unfoldable pat:and. 92 ;; Split into submatrixes (sequences of rows) starting with similar patterns, 93 ;; handle according to similarity, then recursively optimize submatrixes. 94 (define (optimize-matrix* rows) 95 (define row1 (car rows)) 96 (define pat1 (car (pk1-patterns row1))) 97 (define k1 (pk1-k row1)) 98 ;; Now accumulate rows starting with patterns like pat1 99 (define-values (like? combine) (pattern->partitioner pat1)) 100 (let loop ([rows (cdr rows)] [rrows (list row1)]) 101 (cond [(null? rows) 102 (cons (combine (reverse rrows)) null)] 103 [else 104 (define row1 (car rows)) 105 (define pat1 (car (pk1-patterns row1))) 106 (cond [(like? pat1) 107 (loop (cdr rows) (cons row1 rrows))] 108 [else 109 (cons (combine (reverse rrows)) 110 (optimize-matrix* rows))])]))) 111 112 ;; pattern->partitioner : pattern -> (values (pattern -> boolean) ((listof pk1) -> PK)) 113 (define (pattern->partitioner pat1) 114 (match pat1 115 [(pat:pair head tail) 116 (values (lambda (p) (pat:pair? p)) 117 (lambda (rows) 118 (when DEBUG-OPT-SUCCEED 119 (eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1))) 120 (cond [(> (length rows) 1) 121 (pk/pair (optimize-matrix 122 (for/list ([row (in-list rows)]) 123 (let* ([patterns (pk1-patterns row)] 124 [pat1 (car patterns)]) 125 (pk1 (list* (pat:pair-head pat1) 126 (pat:pair-tail pat1) 127 (cdr patterns)) 128 (pk1-k row))))))] 129 [else (car rows)])))] 130 [(? pattern-factorable?) 131 (values (lambda (pat2) (pattern-equal? pat1 pat2)) 132 (lambda (rows) 133 (when DEBUG-OPT-SUCCEED 134 (eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1))) 135 (cond [(> (length rows) 1) 136 (pk/same pat1 137 (optimize-matrix 138 (for/list ([row (in-list rows)]) 139 (pk1 (cdr (pk1-patterns row)) (pk1-k row)))))] 140 [else (car rows)])))] 141 [_ 142 (values (lambda (pat2) 143 (when DEBUG-OPT-FAIL 144 (when (pattern-equal? pat1 pat2) 145 (eprintf "** cannot factor: ~e\n" (syntax->datum #`#,pat2)))) 146 #f) 147 (lambda (rows) 148 ;; (length rows) = 1 149 (car rows)))])) 150 151 ;; unfold-and : pattern (listof pattern) -> (values pattern (listof pattern)) 152 (define (unfold-and p onto) 153 (match p 154 [(pat:and subpatterns) 155 ;; pat:and is worth unfolding if first subpattern is not pat:action 156 ;; if first subpattern is also pat:and, keep unfolding 157 (let* ([first-sub (car subpatterns)] 158 [rest-subs (cdr subpatterns)]) 159 (cond [(not (pat:action? first-sub)) 160 (when #f ;; DEBUG-OPT-SUCCEED 161 (eprintf ">> unfolding: ~e\n" p)) 162 (unfold-and first-sub (*append rest-subs onto))] 163 [else (values p onto)]))] 164 [_ (values p onto)])) 165 166 (define (pattern-factorable? p) 167 ;; Can factor out p if p can succeed at most once, does not cut 168 ;; - if p can succeed multiple times, then factoring changes success order 169 ;; - if p can cut, then factoring changes which choice points are discarded (too few) 170 (match p 171 [(pat:any) #t] 172 [(pat:svar _n) #t] 173 [(pat:var/p _ _ _ _ _ (scopts _ commit? _ _)) 174 ;; commit? implies delimit-cut 175 commit?] 176 [(? pat:integrated?) #t] 177 [(pat:literal _lit _ip _lp) #t] 178 [(pat:datum _datum) #t] 179 [(pat:action _act _pat) #f] 180 [(pat:head head tail) 181 (and (pattern-factorable? head) 182 (pattern-factorable? tail))] 183 [(pat:dots heads tail) 184 ;; Conservative approximation for common case: one head pattern 185 ;; In general, check if heads don't overlap, don't overlap with tail. 186 (and (= (length heads) 1) 187 (let ([head (car heads)]) 188 (and (pattern-factorable? head))) 189 (equal? tail (pat:datum '())))] 190 [(pat:and patterns) 191 (andmap pattern-factorable? patterns)] 192 [(pat:or patterns) #f] 193 [(pat:not pattern) #f] ;; FIXME: ? 194 [(pat:pair head tail) 195 (and (pattern-factorable? head) 196 (pattern-factorable? tail))] 197 [(pat:vector pattern) 198 (pattern-factorable? pattern)] 199 [(pat:box pattern) 200 (pattern-factorable? pattern)] 201 [(pat:pstruct key pattern) 202 (pattern-factorable? pattern)] 203 [(pat:describe pattern _desc _trans _role) 204 (pattern-factorable? pattern)] 205 [(pat:delimit pattern) 206 (pattern-factorable? pattern)] 207 [(pat:commit pattern) #t] 208 [(? pat:reflect?) #f] 209 [(pat:ord pattern _ _) 210 (pattern-factorable? pattern)] 211 [(pat:post pattern) 212 (pattern-factorable? pattern)] 213 ;; ---- 214 [(hpat:var/p _ _ _ _ _ (scopts _ commit? _ _)) 215 commit?] 216 [(hpat:seq inner) 217 (pattern-factorable? inner)] 218 [(hpat:commit inner) #t] 219 ;; ---- 220 [(ehpat head repc) 221 (and (equal? repc #f) 222 (pattern-factorable? head))] 223 ;; ---- 224 [else #f])) 225 226 (define (subpatterns-equal? as bs) 227 (and (= (length as) (length bs)) 228 (for/and ([a (in-list as)] 229 [b (in-list bs)]) 230 (pattern-equal? a b)))) 231 232 (define (pattern-equal? a b) 233 (define result 234 (cond [(and (pat:any? a) (pat:any? b)) #t] 235 [(and (pat:svar? a) (pat:svar? b)) 236 (bound-identifier=? (pat:svar-name a) (pat:svar-name b))] 237 [(and (pat:var/p? a) (pat:var/p? b)) 238 (and (free-id/f-equal? (pat:var/p-parser a) (pat:var/p-parser b)) 239 (bound-id/f-equal? (pat:var/p-name a) (pat:var/p-name b)) 240 (equal-iattrs? (pat:var/p-nested-attrs a) (pat:var/p-nested-attrs b)) 241 (equal-argu? (pat:var/p-argu a) (pat:var/p-argu b)) 242 (expr-equal? (pat:var/p-role a) (pat:var/p-role b)))] 243 [(and (pat:integrated? a) (pat:integrated? b)) 244 (and (bound-id/f-equal? (pat:integrated-name a) (pat:integrated-name b)) 245 (free-identifier=? (pat:integrated-predicate a) 246 (pat:integrated-predicate b)) 247 (expr-equal? (pat:integrated-role a) (pat:integrated-role b)))] 248 [(and (pat:literal? a) (pat:literal? b)) 249 ;; literals are hard to compare, so compare gensyms attached to 250 ;; literal ids (see rep.rkt) instead 251 (let ([ka (syntax-property (pat:literal-id a) 'literal)] 252 [kb (syntax-property (pat:literal-id b) 'literal)]) 253 (and ka kb (eq? ka kb)))] 254 [(and (pat:datum? a) (pat:datum? b)) 255 (equal? (pat:datum-datum a) 256 (pat:datum-datum b))] 257 [(and (pat:head? a) (pat:head? b)) 258 (and (pattern-equal? (pat:head-head a) (pat:head-head b)) 259 (pattern-equal? (pat:head-tail a) (pat:head-tail b)))] 260 [(and (pat:dots? a) (pat:dots? b)) 261 (and (subpatterns-equal? (pat:dots-heads a) (pat:dots-heads b)) 262 (pattern-equal? (pat:dots-tail a) (pat:dots-tail b)))] 263 [(and (pat:and? a) (pat:and? b)) 264 (subpatterns-equal? (pat:and-patterns a) (pat:and-patterns b))] 265 [(and (pat:or? a) (pat:or? b)) 266 (subpatterns-equal? (pat:or-patterns a) (pat:or-patterns b))] 267 [(and (pat:not? a) (pat:not? b)) 268 (pattern-equal? (pat:not-pattern a) (pat:not-pattern b))] 269 [(and (pat:pair? a) (pat:pair? b)) 270 (and (pattern-equal? (pat:pair-head a) (pat:pair-head b)) 271 (pattern-equal? (pat:pair-tail a) (pat:pair-tail b)))] 272 [(and (pat:vector? a) (pat:vector? b)) 273 (pattern-equal? (pat:vector-pattern a) (pat:vector-pattern b))] 274 [(and (pat:box? a) (pat:box? b)) 275 (pattern-equal? (pat:box-pattern a) (pat:box-pattern b))] 276 [(and (pat:pstruct? a) (pat:pstruct? b)) 277 (and (equal? (pat:pstruct-key a) 278 (pat:pstruct-key b)) 279 (pattern-equal? (pat:pstruct-pattern a) 280 (pat:pstruct-pattern b)))] 281 [(and (pat:describe? a) (pat:describe? b)) #f] ;; can't compare desc exprs 282 [(and (pat:delimit? a) (pat:delimit? b)) 283 (pattern-equal? (pat:delimit-pattern a) (pat:delimit-pattern b))] 284 [(and (pat:commit? a) (pat:commit? b)) 285 (pattern-equal? (pat:commit-pattern a) (pat:commit-pattern b))] 286 [(and (pat:reflect? a) (pat:reflect? b)) #f] ;; FIXME: ? 287 [(and (pat:ord? a) (pat:ord? b)) 288 (and (pattern-equal? (pat:ord-pattern a) (pat:ord-pattern b)) 289 (equal? (pat:ord-group a) (pat:ord-group b)) 290 (equal? (pat:ord-index a) (pat:ord-index b)))] 291 [(and (pat:post? a) (pat:post? b)) 292 (pattern-equal? (pat:post-pattern a) (pat:post-pattern b))] 293 ;; --- 294 [(and (hpat:var/p? a) (hpat:var/p? b)) 295 (and (free-id/f-equal? (hpat:var/p-parser a) (hpat:var/p-parser b)) 296 (bound-id/f-equal? (hpat:var/p-name a) (hpat:var/p-name b)) 297 (equal-iattrs? (hpat:var/p-nested-attrs a) (hpat:var/p-nested-attrs b)) 298 (equal-argu? (hpat:var/p-argu a) (hpat:var/p-argu b)) 299 (expr-equal? (hpat:var/p-role a) (hpat:var/p-role b)))] 300 [(and (hpat:seq? a) (hpat:seq? b)) 301 (pattern-equal? (hpat:seq-inner a) (hpat:seq-inner b))] 302 ;; --- 303 [(and (ehpat? a) (ehpat? b)) 304 (and (equal? (ehpat-repc a) #f) 305 (equal? (ehpat-repc b) #f) 306 (pattern-equal? (ehpat-head a) (ehpat-head b)))] 307 ;; FIXME: more? 308 [else #f])) 309 (when DEBUG-OPT-FAIL 310 (when (and (eq? result #f) 311 (equal? (syntax->datum #`#,a) (syntax->datum #`#,b))) 312 (eprintf "** pattern-equal? failed on ~e\n" a))) 313 result) 314 315 (define (equal-iattrs? as bs) 316 (and (= (length as) (length bs)) 317 ;; assumes attrs in same order 318 (for/and ([aa (in-list as)] 319 [ba (in-list bs)]) 320 (and (bound-identifier=? (attr-name aa) (attr-name ba)) 321 (equal? (attr-depth aa) (attr-depth ba)) 322 (equal? (attr-syntax? aa) (attr-syntax? ba)))))) 323 324 (define (expr-equal? a b) 325 ;; Expression equality is undecidable in general. Especially difficult for unexpanded 326 ;; code, but it would be very difficult to set up correct env for local-expand because of 327 ;; attr binding rules. So, do *very* conservative approx: simple variables and literals. 328 ;; FIXME: any other common cases? 329 (cond [(not (and (syntax? a) (syntax? b))) 330 (equal? a b)] 331 [(and (identifier? a) (identifier? b)) 332 ;; note: "vars" might be identifier macros (unsafe to consider equal), 333 ;; so check var has no compile-time binding 334 (and (free-identifier=? a b) 335 (let/ec k (syntax-local-value a (lambda () (k #t))) #f))] 336 [(syntax-case (list a b) (quote) 337 [((quote ad) (quote bd)) 338 (cons (syntax->datum #'ad) (syntax->datum #'bd))] 339 [_ #f]) 340 => (lambda (ad+bd) 341 (equal? (car ad+bd) (cdr ad+bd)))] 342 [else 343 ;; approx: equal? only if both simple data (bool, string, etc), no inner stx 344 (let ([ad (syntax-e a)] 345 [bd (syntax-e b)]) 346 (and (equal? ad bd) 347 (free-identifier=? (datum->syntax a '#%datum) #'#%datum) 348 (free-identifier=? (datum->syntax b '#%datum) #'#%datum)))])) 349 350 (define (equal-argu? a b) 351 (define (unwrap-arguments x) 352 (match x 353 [(arguments pargs kws kwargs) 354 (values pargs kws kwargs)])) 355 (define (list-equal? as bs inner-equal?) 356 (and (= (length as) (length bs)) 357 (andmap inner-equal? as bs))) 358 (let-values ([(apargs akws akwargs) (unwrap-arguments a)] 359 [(bpargs bkws bkwargs) (unwrap-arguments b)]) 360 (and (list-equal? apargs bpargs expr-equal?) 361 (equal? akws bkws) 362 (list-equal? akwargs bkwargs expr-equal?)))) 363 364 (define (free-id/f-equal? a b) 365 (or (and (eq? a #f) 366 (eq? b #f)) 367 (and (identifier? a) 368 (identifier? b) 369 (free-identifier=? a b)))) 370 371 (define (bound-id/f-equal? a b) 372 (or (and (eq? a #f) 373 (eq? b #f)) 374 (and (identifier? a) 375 (identifier? b) 376 (bound-identifier=? a b)))) 377 378 (define (make-and-pattern subs) 379 (cond [(null? subs) (pat:any)] ;; shouldn't happen 380 [(null? (cdr subs)) (car subs)] 381 [else (pat:and subs)])) 382 383 (define (*append a b) (if (null? b) a (append a b))) 384 385 (define (stx-e x) (if (syntax? x) (syntax-e x) x)) 386 387 ;; ---- 388 389 (define (matrix->sexpr rows) 390 (cond [(null? rows) ;; shouldn't happen 391 '(FAIL)] 392 [(null? (cdr rows)) 393 (pk->sexpr (car rows))] 394 [else 395 (cons 'TRY (map pk->sexpr rows))])) 396 (define (pk->sexpr pk) 397 (match pk 398 [(pk1 pats k) 399 (cons 'MATCH (map pattern->sexpr pats))] 400 [(pk/same pat inner) 401 (list 'SAME (pattern->sexpr pat) (matrix->sexpr inner))] 402 [(pk/pair inner) 403 (list 'PAIR (matrix->sexpr inner))] 404 [(pk/and inner) 405 (list 'AND (matrix->sexpr inner))])) 406 (define (pattern->sexpr p) 407 (match p 408 [(pat:any) '_] 409 [(pat:integrated name pred desc _) 410 (format-symbol "~a:~a" (or name '_) desc)] 411 [(pat:svar name) 412 (syntax-e name)] 413 [(pat:var/p name parser _ _ _ _) 414 (cond [(and parser (regexp-match #rx"^parse-(.*)$" (symbol->string (syntax-e parser)))) 415 => (lambda (m) 416 (format-symbol "~a:~a" (or name '_) (cadr m)))] 417 [else 418 (if name (syntax-e name) '_)])] 419 [(? pat:literal?) `(quote ,(syntax->datum (pat:literal-id p)))] 420 [(pat:datum datum) datum] 421 [(? pat:action?) 'ACTION] 422 [(pat:pair head tail) 423 (cons (pattern->sexpr head) (pattern->sexpr tail))] 424 [(pat:head head tail) 425 (cons (pattern->sexpr head) (pattern->sexpr tail))] 426 [(pat:dots (list eh) tail) 427 (list* (pattern->sexpr eh) '... (pattern->sexpr tail))] 428 [(ehpat _as hpat '#f _cn) 429 (pattern->sexpr hpat)] 430 [_ 'PATTERN]))