[plt-scheme] New Match Implementation

On Wed, 26 Mar 2008, Sam TH wrote:

> I've just changed the implementation of the various pattern matching
> libraries in PLT (scheme/match, mzlib/plt-match, mzlib/match) to a
> new, from-scratch implementation.  This new implementation should have
> significantly faster compile times, especially with complicated match
> expressions.

Did you break the optimizer?
It now (well, rev 9096) extracts useless elements from compounds for _
patterns.

Case in point:
> (define-syntax-rule (pps e) (pretty-print (syntax->datum (expand 'e))))
> (pps (match foo ((list* _ x) bar)))

(let-values (((foo168) (#%top . foo)))
  (let-values (((fail169) (lambda () (#%app match:error foo168))))
    (if (#%app pair? foo168)
      (begin
        (let-values (((car171) (#%app car foo168))
                     ((cdr172) (#%app cdr foo168)))
          (let-values ()
            (let-values () (let-values (((x) cdr172)) (#%top . bar))))))
      (begin (#%app fail169)))))

This used to expand to [372/old expander]:
(let-values (((x) (#%top . foo)))
  (let-values (((match-failure) (lambda () (#%app match:error x))))
    (if (#%app pair? x)
      (let-values (((x) (#%app cdr x))) (#%top . bar))
      (#%app match-failure))))

Similarly with structs:
> (define-struct test (x y))
> (pps (match foo ((struct test (_ x)) bar)))
(let-values (((foo203) (#%top . foo)))
  (let-values (((fail204) (lambda () (#%app match:error foo203))))
    (if (#%app (#%top . test?) foo203)
      (begin
        (let-values (((test-x206) (#%app (#%top . test-x) foo203))
                     ((test-y207) (#%app (#%top . test-y) foo203)))
          (let-values ()
            (let-values () (let-values (((x) test-y207)) (#%top . bar))))))
      (begin (#%app fail204)))))

It also fails to collapse common code paths.
Compare:
 (pps (match foo ((list 1 2) bar1) ((list 1 _) bar2)))

(let-values (((foo247) (#%top . foo)))
  (let-values (((fail248) (lambda () (#%app match:error foo247))))
    (if (#%app pair? foo247)
      (begin
        (let-values (((car250) (#%app car foo247))
                     ((cdr251) (#%app cdr foo247)))
          (if (#%app equal? car250 '1)
            (begin
              (if (#%app pair? cdr251)
                (begin
                  (let-values (((car254) (#%app car cdr251))
                               ((cdr255) (#%app cdr cdr251)))
                    (let-values (((f256)
                                  (lambda ()
                                    (if (#%app null? cdr255)
                                      (begin
                                        (let-values ()
                                          (let-values () (#%top . bar2))))
                                      (begin (#%app fail248))))))
                      (if (#%app equal? car254 '2)
                        (begin
                          (if (#%app null? cdr255)
                            (begin
                              (let-values () (let-values () (#%top . bar1))))
                            (begin (#%app f256))))
                        (begin (#%app f256))))))
                (begin (#%app fail248))))
            (begin (#%app fail248)))))
      (begin (#%app fail248)))))

with [372/old expander]:
(let-values (((x) (#%top . foo)))
  (let-values (((match-failure) (lambda () (#%app match:error x))))
    (if (if (#%app pair? x)
          (#%app equal? (#%app car x) (#%datum . 1))
          (#%datum . #f))
      (let-values (((exp29) (#%app cdr x)))
        (if (if (#%app pair? exp29)
              (#%app null? (#%app cdr exp29))
              (#%datum . #f))
          (if (#%app equal? (#%app car exp29) (#%datum . 2))
            (let-values () (#%top . bar1))
            (let-values () (#%top . bar2)))
          (#%app match-failure)))
      (#%app match-failure))))

-- vyzo