Skip to content
This repository has been archived by the owner on Dec 29, 2018. It is now read-only.

Commit

Permalink
Improve AND pattern performance
Browse files Browse the repository at this point in the history
  • Loading branch information
Tomohiro Matsuyama committed Nov 5, 2012
1 parent 37eeaf5 commit aed6107
Show file tree
Hide file tree
Showing 3 changed files with 112 additions and 65 deletions.
142 changes: 90 additions & 52 deletions src/compiler.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -123,22 +123,6 @@
(fail)))
,else)))))

(defun compile-match-and-group (vars clauses else)
(assert (= (length clauses) 1))
(destructuring-bind ((pattern . rest) . then)
(first clauses)
(let ((patterns (and-pattern-sub-patterns pattern)))
(unless patterns
(return-from compile-match-and-group else))
`(%match ,(append (make-list (length patterns)
:initial-element (first vars))
(cdr vars))
;; Reverse patterns here so that the pattern matching is
;; executed in order of the patterns. This is important
;; especially for guard patterns.
(((,@(reverse patterns) ,.rest) ,.then))
,else))))

(defun compile-match-not-group (vars clauses else)
(assert (= (length clauses) 1))
(destructuring-bind ((pattern . rest) . then)
Expand Down Expand Up @@ -174,9 +158,7 @@
(not-pattern
(compile-match-not-group vars group fail))
(or-pattern
(compile-match-or-group vars group fail))
(and-pattern
(compile-match-and-group vars group fail)))
(compile-match-or-group vars group fail)))
(compile-match-empty-group group fail))
else)))

Expand All @@ -196,45 +178,101 @@
(constructor-pattern
(equal (constructor-pattern-signature x)
(constructor-pattern-signature y)))
(guard-pattern
((or guard-pattern and-pattern)
(error "Something wrong."))
((or not-pattern or-pattern and-pattern)
((or not-pattern or-pattern)
nil)
(otherwise t)))))
(group clauses :test #'same-group-p :key #'caar)))

(defun preprocess-match-clause (clause)
(if (and (consp clause)
(car clause))
(destructuring-bind (patterns . then) clause
;; Parse and check patterns here.
(setq patterns (mapcar #'parse-pattern patterns))
(check-patterns patterns)
;; Desugar WHEN/UNLESS here.
(cond ((and (>= (length then) 2)
(eq (first then) 'when))
(setq then `((if ,(second then)
(progn ,.(cddr then))
(fail)))))
((and (>= (length then) 2)
(eq (first then) 'unless))
(setq then `((if (not ,(second then))
(progn ,.(cddr then))
(fail))))))
(let ((pattern (first patterns))
(rest (rest patterns)))
;; Recursively expand AND pattern here like:
;;
;; (AND) => _
;; (AND x) => x
;;
(loop while (and-pattern-p pattern)
for sub-patterns = (and-pattern-sub-patterns pattern)
do (case (length sub-patterns)
(0 (setq pattern (parse-pattern '_)))
(1 (setq pattern (first sub-patterns)))
(t (return))))
;; Recursively expand GUARD pattern here.
(loop while (guard-pattern-p pattern) do
(setq then `((if ,(guard-pattern-test-form pattern)
(progn ,.then)
(fail)))
pattern (guard-pattern-sub-pattern pattern)))
`((,pattern ,.rest) ,.then)))
clause))

(defun preprocess-match-clauses (vars clauses)
(let* ((clauses (mapcar #'preprocess-match-clause clauses))
(and-clauses
(loop for clause in clauses
for (patterns . nil) = clause
if (and patterns (and-pattern-p (first patterns)))
collect clause)))
(if and-clauses
;; Recursively expand AND patterns here like:
;;
;; (((AND x y) z)
;; ((AND a b c) d)
;; (p))
;; =>
;; ((x y _ z)
;; (a b c d)
;; (p _ _ _))
;;
(loop with arity
= (loop for ((pattern . nil) . nil) in and-clauses
maximize (length (and-pattern-sub-patterns pattern)))
for clause in clauses
for (patterns . then) = clause
for pattern = (if patterns (first patterns))
for prefix
= (cond ((and-pattern-p pattern)
(and-pattern-sub-patterns pattern))
(pattern
(list pattern)))
for postfix
= (make-list (- arity (length prefix))
:initial-element (parse-pattern '_))
for new-patterns = (append prefix postfix)
collect `(,new-patterns ,.then) into new-clauses
finally (let ((new-vars
(and vars
(append (make-list arity
:initial-element (first vars))
(rest vars)))))
(return (preprocess-match-clauses new-vars new-clauses))))
;; Otherwise, just return the variables and the clauses.
(list vars clauses))))

(defun compile-match (vars clauses else)
(flet ((process-clause (clause)
(if (and (consp clause)
(car clause))
(destructuring-bind (patterns . then) clause
;; Parse patterns here.
;; FIXME: parse-pattern here is redundant.
(setq patterns (mapcar #'parse-pattern patterns))
(check-patterns patterns)
;; Desugar WHEN/UNLESS here.
(cond ((and (>= (length then) 2)
(eq (first then) 'when))
(setq then `((if ,(second then)
(progn ,.(cddr then))
(fail)))))
((and (>= (length then) 2)
(eq (first then) 'unless))
(setq then `((if (not ,(second then))
(progn ,.(cddr then))
(fail))))))
(let ((pattern (first patterns))
(rest (rest patterns)))
;; Expand guard pattern here.
(loop while (guard-pattern-p pattern) do
(setq then `((if ,(guard-pattern-test-form pattern)
(progn ,.then)
(fail)))
pattern (guard-pattern-sub-pattern pattern)))
`((,pattern ,.rest) ,.then)))
clause)))
(let* ((clauses (mapcar #'process-clause clauses))
(groups (group-match-clauses clauses)))
;; FIXME: don't call PREPROCESS-MATCH-CLAUSES two or more times
(destructuring-bind (vars clauses)
(preprocess-match-clauses vars clauses)
(let ((groups (group-match-clauses clauses)))
(compile-match-groups vars groups else))))

(defun compile-match-1 (form clauses else)
Expand Down
22 changes: 11 additions & 11 deletions src/match.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,17 +19,6 @@ progn. If ARG is matched with some PATTERN, then evaluates
corresponding BODY and returns the evaluated value. Otherwise, returns
NIL.
If BODY starts with the symbols WHEN or UNLESS, then the next form
will be used to introduce a guard for PATTERN. That is,
(match list ((list x) when (oddp x) x))
(match list ((list x) unless (evenp x) x))
will be translated to
(match list ((and (list x) (when (oddp x))) x))
(match list ((and (list x) (unless (evenp x))) x))
Evaluating a form (FAIL) in the clause body causes the latest pattern
matching be failed. For example,
Expand All @@ -42,6 +31,17 @@ matching be failed. For example,
returns OK, because the form (FAIL) in the first clause is
evaluated.
If BODY starts with the symbols WHEN or UNLESS, then the next form
will be used to introduce (FAIL). That is,
(match list ((list x) when (oddp x) x))
(match list ((list x) unless (evenp x) x))
will be translated to
(match list ((list x) (if (oddp x) x (fail))))
(match list ((list x) (if (evenp x) (fail) x)))
Examples:
(match 1 (1 1))
Expand Down
13 changes: 11 additions & 2 deletions test/suite.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -136,7 +136,9 @@
(is-match (cons 1 2) (cons _ (when (numberp *))))
(is-not-match (cons 1 2) (cons _ (unless (numberp *))))
(is-not-match 1 (unless t))
#+FIXME
(is-match 1 (and x (when (eql x 1))))
#+FIXME
(is-match 1 (and x (unless (eql x 2))))
;; when bind
(is-match 1 (when (eql * 1)))
Expand Down Expand Up @@ -171,7 +173,7 @@
((or (cons x 2) (cons x 2)))))))))

(test and-pattern
(is-not-match 1 (and))
(is-match 1 (and))
(is-match 1 (and 1))
(is-match 1 (and 1 1))
(is-not-match 1 (and 1 2))
Expand All @@ -180,7 +182,12 @@
(is-match 1 (and 1 (and 1)))
(is-match 1 (and (and 1)))
(is (eql (match 1 ((and 1 x) x)) 1))
(is-not-match 1 (and (and (not 1)))))
(is-not-match 1 (and (and (not 1))))
;; complex
(is-true (match 1
((and 1 2) nil)
(1 t)
(2 nil))))

(test match
;; empty
Expand Down Expand Up @@ -326,13 +333,15 @@
(test issue39
(is (eql (match '(0) ((list x) x))
0))
#+FIXME
(is (eql (match '(0) ((list (and x (when (numberp x)))) x))
0)))

(test issue38
(signals error
(macroexpand '(match 1 ((or (place x) (place x)))))))

#+FIXME
(test issue31
(is (equal (match '(1 2 3 4)
((or (list* (and (typep symbol) x) y z)
Expand Down

0 comments on commit aed6107

Please sign in to comment.