new :USE-CACHE option for DEFRULE

Controls whether the rule should be compiled with caching. This can
yield serious performance improvements. For example, the following

  (defrule uncached.1
      #\a
    (:use-cache nil))

  (defrule uncached.2
      #\b
    (:use-cache nil))

  (defrule uncached.3
      (and (+ uncached.1) (+ uncached.2)))

  (let ((string (concatenate 'string
                             (make-string 100000 :initial-element #\a)
                             (make-string 100000 :initial-element #\b))))
    (time (loop :repeat 100 :do (esrap:parse 'uncached.3 string))))

results in

  Evaluation took:
    3.893 seconds of real time
    3.896476 seconds of total run time (3.616506 user, 0.279970 system)
    [ Run times consist of 1.280 seconds GC time, and 2.617 seconds non-GC time. ]
    100.08% CPU
    11,653,119,545 processor cycles
    3,841,530,688 bytes consed

with :use-cache nil in both rules and

  Evaluation took:
    8.006 seconds of real time
    8.011514 seconds of total run time (7.443860 user, 0.567654 system)
    [ Run times consist of 3.499 seconds GC time, and 4.513 seconds non-GC time. ]
    100.07% CPU
    23,962,183,032 processor cycles
    6,562,762,256 bytes consed

with :use-cache t in both rules.

esrap.asd

@@ -82,6 +82,8 @@
   :in-order-to      ((test-op (test-op "esrap/tests"))))
 
 (defmethod perform :after ((op load-op) (sys (eql (find-system "esrap"))))
+  ;; Since version 0.19
+  ;; * DEFRULE accepts a :USE-CACHE option
   ;; Since version 0.16
   ;; * DEFRULE accepts an :ERROR-REPORT option
   ;; Since version 0.15

src/evaluator.lisp

@@ -1,5 +1,5 @@
 ;;;; Copyright (c) 2007-2013 Nikodemus Siivola <nikodemus@random-state.net>
-;;;; Copyright (c) 2012-2016 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+;;;; Copyright (c) 2012-2019 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
 ;;;;
 ;;;; Permission is hereby granted, free of charge, to any person
 ;;;; obtaining a copy of this software and associated documentation files
@@ -40,7 +40,7 @@
 
 (defvar *current-rule* nil)
 
-(defun compile-rule (symbol expression condition transform around)
+(defun compile-rule (symbol expression condition transform around properties)
   (declare (type (or boolean function) condition transform around))
   (let* ((*current-rule* symbol)
          ;; Must bind *CURRENT-RULE* before compiling the expression!
@@ -49,53 +49,65 @@
          ;; (error) results produced by inactive rules. The actual
          ;; error position has to be added in a post-processing step.
          (rule-not-active (make-inactive-rule symbol 0)))
-    (cond ((not condition)
-           (named-lambda inactive-rule (text position end)
-             (declare (ignore text position end))
-             rule-not-active))
-          (transform
-           (locally (declare (type function transform))
-             (flet ((exec-rule/transform (text position end)
-                      (let ((result (funcall function text position end)))
-                        (if (error-result-p result)
-                            (make-failed-parse/no-position symbol result)
-                            (if around
-                                (locally (declare (type function around))
-                                  (make-successful-parse
-                                   symbol (result-position result)
-                                   result (flet ((call-rule ()
-                                                   (funcall transform
-                                                            (successful-parse-production result)
-                                                            position
-                                                            (result-position result))))
-                                            (funcall around position (result-position result) #'call-rule))))
+    (macrolet
+        ((named-lambda/cache-variants (name lambda-list &body body)
+           `(if (rule-property-p properties :uses-cache)
+                (named-lambda ,name ,lambda-list ,@body)
+                (named-lambda ,name ,lambda-list
+                  (macrolet ((with-cached-result
+                                 ((symbol position text) &body body)
+                               (declare (ignore symbol position text))
+                               `(progn ,@body)))
+                    ,@body)))))
+      (cond
+        ((not condition)
+         (named-lambda inactive-rule (text position end)
+           (declare (ignore text position end))
+           rule-not-active))
+        (transform
+         (locally (declare (type function transform))
+           (flet ((exec-rule/transform (text position end)
+                    (let ((result (funcall function text position end)))
+                      (if (error-result-p result)
+                          (make-failed-parse/no-position symbol result)
+                          (if around
+                              (locally (declare (type function around))
                                 (make-successful-parse
                                  symbol (result-position result)
-                                 result (funcall transform
-                                                 (successful-parse-production result)
-                                                 position
-                                                 (result-position result))))))))
-               (if (eq t condition)
-                   (named-lambda rule/transform (text position end)
-                     (with-cached-result (symbol position text)
-                       (exec-rule/transform text position end)))
-                   (locally (declare (type function condition))
-                     (named-lambda condition-rule/transform (text position end)
-                       (with-cached-result (symbol position text)
-                         (if (funcall condition)
-                             (exec-rule/transform text position end)
-                             rule-not-active))))))))
-          (t
-           (if (eq t condition)
-               (named-lambda rule (text position end)
-                 (with-cached-result (symbol position text)
-                   (funcall function text position end)))
-               (locally (declare (type function condition))
-                 (named-lambda conditional-rule (text position end)
+                                 result (flet ((call-rule ()
+                                                 (funcall transform
+                                                          (successful-parse-production result)
+                                                          position
+                                                          (result-position result))))
+                                          (funcall around position (result-position result) #'call-rule))))
+                              (make-successful-parse
+                               symbol (result-position result)
+                               result (funcall transform
+                                               (successful-parse-production result)
+                                               position
+                                               (result-position result))))))))
+             (if (eq t condition)
+                 (named-lambda/cache-variants rule/transform (text position end)
                    (with-cached-result (symbol position text)
-                     (if (funcall condition)
-                         (funcall function text position end)
-                         rule-not-active)))))))))
+                     (exec-rule/transform text position end)))
+                 (locally (declare (type function condition))
+                   (named-lambda/cache-variants
+                    condition-rule/transform (text position end)
+                    (with-cached-result (symbol position text)
+                      (if (funcall condition)
+                          (exec-rule/transform text position end)
+                          rule-not-active))))))))
+        (t
+         (if (eq t condition)
+             (named-lambda/cache-variants rule (text position end)
+               (with-cached-result (symbol position text)
+                 (funcall function text position end)))
+             (locally (declare (type function condition))
+               (named-lambda/cache-variants conditional-rule (text position end)
+                 (with-cached-result (symbol position text)
+                   (if (funcall condition)
+                       (funcall function text position end)
+                       rule-not-active))))))))))
 
 ;;; EXPRESSION COMPILER & EVALUATOR
 

src/interface.lisp

@@ -1,5 +1,5 @@
 ;;;; Copyright (c) 2007-2013 Nikodemus Siivola <nikodemus@random-state.net>
-;;;; Copyright (c) 2012-2017 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+;;;; Copyright (c) 2012-2019 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
 ;;;;
 ;;;; Permission is hereby granted, free of charge, to any person
 ;;;; obtaining a copy of this software and associated documentation files
@@ -197,6 +197,19 @@ Following OPTIONS can be specified:
     This option can be used to safely track nesting depth, manage symbol
     tables or for other stack-like operations.
 
+  * (:USE-CACHE BOOLEAN)
+
+    Defaults to T if not provided. Controls whether the rule should be
+    compiled with caching.
+
+    For rules with simple expressions, the overhead of cache lookup
+    and update can by far exceed the cost of simply evaluating the
+    rule expression. Disabling caching can improve performance in such
+    cases.
+
+    Note that disabling caching can change the behavior of the rule,
+    for example when the rule transform returns a fresh object.
+
   * (:ERROR-REPORT ( T | NIL | :CONTEXT | :DETAIL ))
 
     Defaults to T if not provided. Controls whether and how the rule
@@ -230,17 +243,20 @@ Following OPTIONS can be specified:
       reports, but can appear in the list of failed rules. Inputs
       expected by the rule are mentioned as well.
 "
-  (multiple-value-bind (transforms around when error-report)
+  (multiple-value-bind (transforms around when error-report use-cache)
       (parse-defrule-options options form)
-    (let ((transform (expand-transforms transforms)))
+    (let ((transform (expand-transforms transforms))
+          (properties (make-rule-properties
+                       :uses-cache use-cache)))
       `(eval-when (:load-toplevel :execute)
          (add-rule ',symbol (make-instance 'rule
                                            :expression ',expression
                                            :guard-expression ',(cdr when)
                                            :condition ,(car when)
                                            :transform ,transform
                                            :around ,around
-                                           :error-report ,error-report))))))
+                                           :error-report ,error-report
+                                           :properties ,properties))))))
 
 (defun add-rule (symbol rule)
   "Associates RULE with the nonterminal SYMBOL. Signals an error if the
@@ -256,7 +272,8 @@ associated with a rule, the old rule is removed first."
                                  (rule-expression rule)
                                  (rule-condition rule)
                                  (rule-transform rule)
-                                 (rule-around rule)))
+                                 (rule-around rule)
+                                 (rule-properties rule)))
          (trace-info (cell-trace-info cell)))
     (set-cell-info cell function rule)
     (setf (cell-trace-info cell)     nil

src/macros.lisp

@@ -1,5 +1,5 @@
 ;;;; Copyright (c) 2007-2013 Nikodemus Siivola <nikodemus@random-state.net>
-;;;; Copyright (c) 2012-2017 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+;;;; Copyright (c) 2012-2019 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
 ;;;;
 ;;;; Permission is hereby granted, free of charge, to any person
 ;;;; obtaining a copy of this software and associated documentation files
@@ -178,7 +178,9 @@ for use with IGNORE."
         (transform nil)
         (around nil)
         (error-report (singleton-option 'defrule form :error-report
-                                        'rule-error-report :default t)))
+                                        'rule-error-report :default t))
+        (use-cache (singleton-option 'defrule form :use-cache
+                                     'cache-policy :default t)))
     (dolist (option options)
       (with-current-source-form (option)
         (destructuring-ecase option
@@ -231,9 +233,12 @@ for use with IGNORE."
                                (flet ((call-transform ()
                                         (funcall transform)))
                                  ,@forms))))))
+          ((:use-cache value)
+           (funcall use-cache value))
           ((:error-report behavior)
            (funcall error-report behavior)))))
-    (values transform around (funcall when) (funcall error-report))))
+    (values transform around (funcall when)
+            (funcall error-report) (funcall use-cache))))
 
 (defun expand-transforms (transforms)
   (labels

src/rule.lisp

@@ -35,15 +35,14 @@
                                        `(if ,symbol ,(ash 1 index) 0)))
                              symbol+index)))
             (defun rule-property-p (properties property)
-              ,(when properties
-                 `(logbitp
-                   (ecase property
-                     ,@(map 'list (lambda (entry)
-                                    (destructuring-bind (symbol index) entry
-                                      `(,(make-keyword symbol) ,index)))
-                        symbol+index))
-                   properties)))))))
-  (define))
+              (logbitp
+               (ecase property
+                 ,@(map 'list (lambda (entry)
+                                (destructuring-bind (symbol index) entry
+                                  `(,(make-keyword symbol) ,index)))
+                    symbol+index))
+               properties))))))
+  (define uses-cache))
 
 ;;; RULE REPRESENTATION AND STORAGE
 ;;;

src/types.lisp

@@ -1,5 +1,5 @@
 ;;;; Copyright (c) 2007-2013 Nikodemus Siivola <nikodemus@random-state.net>
-;;;; Copyright (c) 2012-2017 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+;;;; Copyright (c) 2012-2019 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
 ;;;;
 ;;;; Permission is hereby granted, free of charge, to any person
 ;;;; obtaining a copy of this software and associated documentation files
@@ -62,6 +62,9 @@ characters."
 
 ;;; Rule-related types
 
+(deftype cache-policy ()
+  '(member nil t))
+
 (deftype error-report-part ()
   "Named part of a parse error report."
   `(member :context :detail))

test/tests.lisp

@@ -1,5 +1,5 @@
 ;;;; Copyright (c) 2007-2013 Nikodemus Siivola <nikodemus@random-state.net>
-;;;; Copyright (c) 2012-2018 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+;;;; Copyright (c) 2012-2019 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
 ;;;;
 ;;;; Permission is hereby granted, free of charge, to any person
 ;;;; obtaining a copy of this software and associated documentation files
@@ -133,7 +133,13 @@
                  (:error-report "invalid")))
     (test-case '(defrule error-report.repeated "foo"
                   (:error-report nil)
-                  (:error-report t)))))
+                  (:error-report t)))
+
+    (test-case '(defrule use-cache.invalid "foo"
+                  (:use-cache 5)))
+    (test-case '(defrule use-cache.repeated "foo"
+                  (:use-cache nil)
+                  (:use-cache t)))))
 
 ;;; A few semantic predicates
 
@@ -868,6 +874,28 @@
   (is (equal '(2 0 1) (parse 'multiple-transforms.2 "1")))
   (is (equal '(1 0) (parse 'multiple-transforms.3 "1"))))
 
+;;; Test uncached rules
+
+(defrule uncached.1
+    #\a
+  (:use-cache nil))
+
+(defrule uncached.2
+    #\b
+  (:use-cache t))
+
+(defrule uncached
+    (and (+ uncached.1) (+ uncached.2)))
+
+(test-both-modes uncached
+  "Test uncached rules."
+  (flet ((test-case (input expected)
+           (is (equal expected (parse 'uncached input)))))
+    (test-case "ab"   '(("a")     ("b")))
+    (test-case "aab"  '(("a" "a") ("b")))
+    (test-case "abb"  '(("a")     ("b" "b")))
+    (test-case "aabb" '(("a" "a") ("b" "b")))))
+
 ;;; Test rule introspection
 
 (defrule expression-start-terminals.1