quick-match.rkt

#lang racket

(require
  (for-syntax syntax/parse racket/syntax racket/list))

(begin-for-syntax
  (define-syntax-class pattern1
    #:attributes (pred extract vars)
    (pattern x:number
      #:attr pred #'(lambda (v) (equal? v x))
      #:attr extract #'(lambda (v) (values))
      #:attr vars (list))
    (pattern x:id
      #:attr pred #'(lambda (v) #t)
      #:attr extract #'(lambda (v) v)
      #:attr vars (list #'x))
    (pattern (#:cons l:pattern1 r:pattern1)
      #:attr pred #'(lambda (v) (and (pair? v) (l.pred (car v)) (r.pred (cdr v))))
      #:attr extract #`(lambda (v)
                         (let-values ([#,(attribute l.vars) (l.extract (car v))]
                                      [#,(attribute r.vars) (r.extract (cdr v))])
                           (values #,@(attribute l.vars) #,@(attribute r.vars))))
      #:attr vars (append (attribute l.vars) (attribute r.vars)))))

(define-syntax simple-match
  (syntax-parser
    [(_ expr [pat:pattern1 body:expr])
     #`(let ([v expr])
         (cond
           [(pat.pred v) (call-with-values (lambda () (pat.extract v)) (lambda #,(attribute pat.vars) body))]
           [else (error 'bad)]))]))


(begin-for-syntax
  (define-syntax-class pattern2
    #:attributes (pred pred-id pred-bindings extract vars)
    (pattern x:number
      #:attr pred #'(lambda (v) (equal? v x))
      #:attr pred-id (generate-temporary)
      #:attr pred-bindings (list #'[pred-id pred])
      #:attr extract #'(lambda (v) (values))
      #:attr vars (list))
    (pattern x:id
      #:attr pred #'(lambda (v) #t)
      #:attr pred-id (generate-temporary)
      #:attr pred-bindings (list #'[pred-id pred])
      #:attr extract #'(lambda (v) v)
      #:attr vars (list #'x))
    (pattern (#:cons l:pattern2 r:pattern2)
      #:attr pred #'(lambda (v) (and (pair? v) (l.pred-id (car v)) (r.pred-id (cdr v))))
      #:attr pred-id (generate-temporary)
      #:attr pred-bindings (list (attribute l.pred-bindings) (attribute r.pred-bindings) #'[pred-id pred])
      #:attr extract #`(lambda (v)
                         (let-values ([#,(attribute l.vars) (l.extract (car v))]
                                      [#,(attribute r.vars) (r.extract (cdr v))])
                           (values #,@(attribute l.vars) #,@(attribute r.vars))))
      #:attr vars (append (attribute l.vars) (attribute r.vars)))))

(define-syntax simple-match2
  (syntax-parser
    [(_ expr [pat:pattern2 body:expr])
     #`(let ([v expr])
         (cond
           [(letrec #,(flatten (attribute pat.pred-bindings)) (pat.pred v))
            (call-with-values (lambda () (pat.extract v)) (lambda #,(attribute pat.vars) body))]
           [else (error 'bad)]))]))


(begin-for-syntax
  (define-syntax-class pattern3
    #:attributes (matcher vars pred-id pred-bindings)
    (pattern x:number
      #:attr matcher #'(lambda (v sk fk) (if (equal? v x) (sk) (fk)))
      #:attr pred-id (generate-temporary)
      #:attr pred-bindings (list #'[pred-id matcher])
      #:attr vars (list))
    (pattern x:id
      #:attr matcher #'(lambda (v sk fk) (sk v))
      #:attr pred-id (generate-temporary)
      #:attr pred-bindings (list #'[pred-id matcher])
      #:attr vars (list #'x))
    (pattern (#:cons l:pattern3 r:pattern3)
      #:attr matcher
        #`(lambda (v sk fk)
            (if (pair? v)
                (l.pred-id (car v) (lambda (#,@(attribute l.vars)) (r.pred-id (cdr v) (lambda (#,@(attribute r.vars)) (sk #,@(attribute l.vars) #,@(attribute r.vars))) fk)) fk)
                (fk)))
      #:attr pred-id (generate-temporary)
      #:attr pred-bindings (list (attribute l.pred-bindings) (attribute r.pred-bindings)
                                 #'[pred-id matcher])
      #:attr vars (append (attribute l.vars) (attribute r.vars)))))

(define-syntax simple-match3
  (syntax-parser
    [(_ expr [pat:pattern3 body:expr])
     #`(let ([v expr])
         ((letrec #,(flatten (attribute pat.pred-bindings)) pat.pred-id)
          v
          (lambda (#,@(attribute pat.vars)) body)
          (lambda () (error 'bad))))]))


#;
(define foo
  (lambda (x)
    (simple-match x
      [(#:cons (#:cons a b) (#:cons c d)) (+ a b c d)])))

#;
(define bar
  (lambda (x)
    (match x
      [(cons (cons a b) (cons c d)) (+ a b c d)])))

#;
(define baz
  (lambda (x)
    (simple-match3 x
      [(#:cons
         (#:cons (#:cons (#:cons a b) (#:cons c d)) (#:cons (#:cons e f) (#:cons g h)))
         (#:cons (#:cons (#:cons i j) (#:cons k l)) (#:cons (#:cons m n) (#:cons o p))))
       (+ a b c d e f g h i j k l m n o p)])))


(begin 
(require racket/syntax)

(define (time-expansion form)
  (time
    (for ([i 10])
      (expand form))))

(define (time-eval tree-size form)
  (define f (eval form))
  (define x (eval (gen-complete-tree tree-size #'cons 0)))
  (collect-garbage)
  (time
    (for ([i 1000])
      (f x))))


(define (gen-complete-tree depth node [val-thunk (lambda () (generate-temporary))])
  (cond
    [(zero? depth) (if (procedure? val-thunk) (val-thunk) val-thunk)]
    [else #`(#,node #,(gen-complete-tree (sub1 depth) node val-thunk)
                    #,(gen-complete-tree (sub1 depth) node val-thunk))]))


#;
(for ([tree-size (in-list (list 3 3 4 4 5 5 6 6 7 7 8 8 9 9))])
  (displayln tree-size)
  (collect-garbage)
  (time-expansion
    #`(simple-match #,(gen-complete-tree tree-size #'cons 0)
       [#,(gen-complete-tree tree-size '#:cons) 0]))
  (collect-garbage)
  (time-expansion
    #`(simple-match3 #,(gen-complete-tree tree-size #'cons 0)
       [#,(gen-complete-tree tree-size '#:cons) 0]))
  (collect-garbage)
  (time-expansion
    #`(match #,(gen-complete-tree tree-size #'cons 0)
       [#,(gen-complete-tree tree-size #'cons) 0])))

(for ([tree-size (in-list (list 6 6 7 7 8 8 9 9 10 10))])
  (displayln tree-size)

  (collect-garbage)
  (time-eval tree-size
    #`(lambda (x)
        (simple-match x
         [#,(gen-complete-tree tree-size '#:cons) 0])))

  (collect-garbage)
  (time-eval tree-size
    #`(lambda (x)
        (simple-match3 x
         [#,(gen-complete-tree tree-size '#:cons) 0])))

  (collect-garbage)
  (time-eval tree-size
    #`(lambda (x)
        (match x
         [#,(gen-complete-tree tree-size #'cons) 0]))))



#;
(for ([i 5])
  (time-expansion


    #'(simple-match (list* 1 2 3 (cons 3 1) 4 5)
       [(#:cons 1 (#:cons 2 (#:cons a (#:cons (#:cons 3 b) (#:cons y z))))) (+ a b y z)]))
  (time-expansion
    #'(match (list* 1 2 3 (cons 3 1) 4 5)
       [(cons 1 (cons 2 (cons a (cons (cons 3 b) (cons y z))))) (+ a b y z)]))))