*** empty log message ***

original commit: 76e737f04605b6052fe113760324c78d1aa1d1ae

collects/parser-tools/private-yacc/parser-actions.ss

@@ -1,19 +1,27 @@
 (module parser-actions mzscheme
   (require "grammar.ss")
-  (provide (all-defined))
+  (provide (all-defined-except make-reduce make-reduce*)
+           (rename make-reduce* make-reduce))
 
   ;; An action is 
   ;;  - (make-shift int)
-  ;;  - (make-reduce prod)
+  ;;  - (make-reduce prod runtime-action)
   ;;  - (make-accept)
   ;;  - (make-goto int)
+  ;; A reduce contains a runtime-reduce so that sharing of the reduces can
+  ;; be easily transferred to sharing of runtime-reduces.
   
   (define-struct action () (make-inspector))
   (define-struct (shift action) (state) (make-inspector))
-  (define-struct (reduce action) (prod) (make-inspector))
+  (define-struct (reduce action) (prod runtime-reduce) (make-inspector))
   (define-struct (accept action) () (make-inspector))
   (define-struct (goto action) (state) (make-inspector))
   
+  (define (make-reduce* p)
+    (make-reduce p
+                 (vector (prod-index p)
+                         (gram-sym-symbol (prod-lhs p))
+                         (vector-length (prod-rhs p)))))
 
   ;; A runtime-action is
   ;; non-negative-int        (shift)
@@ -24,11 +32,7 @@
   (define (action->runtime-action a)
     (cond
       ((shift? a) (shift-state a))
-      ((reduce? a)
-       (let ((p (reduce-prod a)))
-         (vector (prod-index p)
-                 (gram-sym-symbol (prod-lhs p))
-                 (vector-length (prod-rhs p)))))
+      ((reduce? a) (reduce-runtime-reduce a))
       ((accept? a) 'accept)
       ((goto? a) (- (+ (goto-state a) 1)))))
   

collects/parser-tools/private-yacc/parser-builder.ss

@@ -69,7 +69,7 @@
         #`(when #f
             (let ((bind void) ... (tmp void) ...)
               (void bound ... ... term-group ... start ... end ... prec ...))))))
-  
+  (require (lib "list.ss") "parser-actions.ss")
   (define (build-parser filename src-pos suppress input-terms start end assocs prods)
     (let* ((grammar (parse-input input-terms start end assocs prods src-pos))
            (table (build-table grammar filename suppress))
@@ -79,6 +79,28 @@
       (for-each (lambda (term)
                   (hash-table-put! all-tokens (gram-sym-symbol term) #t))
                 (send grammar get-terms))
+      #;(let ((num-states (vector-length table))
+            (num-gram-syms (+ (send grammar get-num-terms)
+                              (send grammar get-num-non-terms)))
+            (num-ht-entries (apply + (map length (vector->list table))))
+            (num-reduces
+             (let ((ht (make-hash-table)))
+               (for-each
+                (lambda (x)
+                  (when (reduce? x)
+                    (hash-table-put! ht x #t)))
+                (map cdr (apply append (vector->list table))))
+               (length (hash-table-map ht void)))))
+        (printf "~a states, ~a grammar symbols, ~a hash-table entries, ~a reduces~n"
+                num-states num-gram-syms num-ht-entries num-reduces)
+        (printf "~a -- ~aKB, previously ~aKB~n"
+                (/ (+ 2 num-states
+                      (* 4 num-states) (* 2 1.5 num-ht-entries)
+                      (* 5 num-reduces)) 256.0)
+                (/ (+ 2 num-states
+                      (* 4 num-states) (* 2 2.3 num-ht-entries)
+                      (* 5 num-reduces)) 256.0)
+                (/ (+ 2 (* num-states num-gram-syms) (* 5 num-reduces)) 256.0)))
       (values table
               all-tokens
               actions-code

collects/parser-tools/private-yacc/table.ss

@@ -227,7 +227,8 @@
            (term-vector (list->vector (send g get-terms)))
            (end-terms (send g get-end-terms))
            (table (make-parse-table (send a get-num-states)))
-           (get-lookahead (compute-LA a g)))
+           (get-lookahead (compute-LA a g))
+           (reduce-cache (make-hash-table 'equal)))
 
       (for-each
        (lambda (trans-key/state)
@@ -253,10 +254,15 @@
                (bit-vector-for-each 
                 (lambda (term-index)
                   (unless (start-item? item)
+                    (let ((r (hash-table-get reduce-cache item-prod
+                                             (lambda ()
+                                               (let ((r (make-reduce item-prod)))
+                                                 (hash-table-put! reduce-cache item-prod r)
+                                                 r)))))
                       (table-add! table
                                   (kernel-index state)
                                   (vector-ref term-vector term-index)
-                                (make-reduce item-prod))))
+                                  r))))
                 (get-lookahead state item-prod))))
            (append (hash-table-get (send a get-epsilon-trans) state (lambda () null))
                    (filter (lambda (item)