improve judgment form performance in some situations when

ambiguous judgment forms lead to exponential blowup

pkgs/redex-pkgs/redex-lib/redex/private/judgment-form.rkt

@@ -6,6 +6,7 @@
          "error.rkt"
          "search.rkt"
          racket/trace
+         racket/list
          racket/stxparam
          "term-fn.rkt"
          "rewrite-side-conditions.rkt"
@@ -332,15 +333,30 @@
           (apply trace-call form-name wrapped (assemble mode input spacers))
           outputs)
         (form-proc form-proc input derivation-init)))
+  (remove-duplicates
    (for/list ([v (in-list vecs)])
      (define subs (derivation-with-output-only-subs v))
      (define rulename (derivation-with-output-only-name v))
      (define this-output (derivation-with-output-only-output v))
      (derivation-subs-acc
       (and subs (derivation (cons form-name (assemble mode input this-output))
+                            
+                            ;; just drop the subderivations 
+                            ;; and the name when we know we
+                            ;; won't be using them.
+                            ;; this lets the remove-duplicates
+                            ;; call just above do something 
+                            ;; and possibly avoid exponential blowup
+                            
+                            (if (include-entire-derivation)
                                 rulename
-                           (reverse subs)))
+                                "")
-     this-output)))
+                            (if (include-entire-derivation)
+                                (reverse subs)
+                                '())))
+      this-output))))
+
+(define include-entire-derivation (make-parameter #f))
 
 (define (verify-name-ok orig-name the-name)
   (unless (symbol? the-name)
@@ -797,12 +813,13 @@
                          id-or-not)])
        (check-judgment-arity stx judgment)
        (syntax-property
-        (if id-or-not
+        #`(parameterize ([include-entire-derivation #,derivation?])
+            #,(if id-or-not
                   #`(let ([#,id-or-not '()])
                       #,main-stx)
                   #`(sort #,main-stx
                           string<=?
-                    #:key (λ (x) (format "~s" x))))
+                          #:key (λ (x) (format "~s" x)))))
         'disappeared-use
         (syntax-local-introduce #'form-name)))]
     [(_ stx-name derivation? (not-form-name . _) . _)

pkgs/redex-pkgs/redex-test/redex/tests/tl-test.rkt

@@ -2767,6 +2767,33 @@
       (test (judgment-holds (Q (3 4) number_1) number_1)
                   '(14)))
 
+  (let () 
+    (define-judgment-form empty-language
+      #:mode (J I)
+      [(D any_x) ...
+       --------------
+       (J (any_x ...))])
+    (define-judgment-form empty-language
+      #:mode (D I)
+      [----------- nat
+       (D natural)]
+      [----------- num
+       (D number)])
+
+    ;; this test is designed to check to see if we are
+    ;; avoiding an exponential blow up. On my laptop,
+    ;; a list of length 14 was taking 2 seconds before
+    ;; the fix and 1 msec afterwards. After the fix,
+    ;; a list of length 100 (as below) was also taking 
+    ;; no time.
+    
+    (define-values (_ cpu real gc)
+      (time-apply
+       (λ ()
+         (judgment-holds (J ,(build-list 100 add1))))))
+    (test (< cpu 1000) #t))
+
+
     
     (parameterize ([current-namespace (make-base-namespace)])
       (eval '(require errortrace))