From 3e83a816e288f6b533a7d80e13d7c4741cd107f0 Mon Sep 17 00:00:00 2001
From: Burke Fetscher <bfetscher@racket-lang.org>
Date: Tue, 25 Feb 2014 17:11:17 -0600
Subject: [PATCH] redex: parallelize benchmark generation modes

also, add a timeout (currently 5 mins)
---
 .../redex/examples/benchmark/run-muts.rkt     | 40 +++++++++++++------
 .../redex/examples/benchmark/test-file.rkt    | 27 ++++++++++++-
 2 files changed, 52 insertions(+), 15 deletions(-)

diff --git a/pkgs/redex-pkgs/redex-examples/redex/examples/benchmark/run-muts.rkt b/pkgs/redex-pkgs/redex-examples/redex/examples/benchmark/run-muts.rkt
index a9e3f10fb1..9c4f8c16f4 100644
--- a/pkgs/redex-pkgs/redex-examples/redex/examples/benchmark/run-muts.rkt
+++ b/pkgs/redex-pkgs/redex-examples/redex/examples/benchmark/run-muts.rkt
@@ -49,7 +49,10 @@
              (compose (curry regexp-match #px"^.*([\\d]+)\\.rkt$") path->string)
              (directory-list (get-directory dir))))))))
 
-(define worklist files)
+(struct work (file type))
+
+(define worklist (for*/list ([f files] [t gen-types])
+                   (work f t)))
 
 (define work-sem (make-semaphore 1))
 
@@ -60,25 +63,36 @@
      (semaphore-post work-sem)
      (void)]
     [else
-     (define path (simplify-path (build-path here (car worklist))))
+     (match-define (work file type) (car worklist))
      (set! worklist (cdr worklist))
      (semaphore-post work-sem)
+     (define path (simplify-path (build-path here file)))
+     (define output-name (string-append (first 
+                                         (regexp-split #rx"\\."
+                                                       (last (regexp-split #rx"/" file))))
+                                        "-"
+                                        (symbol->string type)
+                                        "-results.rktd"))
      (define args (apply string-append 
-                         (add-between (list* (if verbose? "-v" "")
-                                             (string-append "-m " (number->string minutes))
-                                             (map (λ (t)
-                                                    (string-append "-t "
-                                                                   (symbol->string t))) 
-                                                  gen-types))
+                         (add-between (list (if verbose? "-v" "")
+                                            (string-append "-m " (number->string minutes))
+                                            (string-append "-o " output-name)
+                                            (string-append "-t "
+                                                           (symbol->string type)))
                                       " ")))
-     (system (let ([ans (apply string-append (add-between (list "racket" (path->string (build-path here "test-file.rkt"))
-                                                                args (path->string path)) " "))])
-               (printf "~s\n" ans)
-               ans))
+     (define command (apply string-append 
+                            (add-between (list "racket" (path->string (build-path here "test-file.rkt"))
+                                               args (path->string path)) " ")))
+     (printf "running: ~s\n" command)
+     (system command)
      (do-next)]))
 
 (define (do-work)
-  (displayln worklist)
+  (printf "worklist:\n~a\n" (apply string-append
+                                   (add-between (for/list ([w (in-list worklist)])
+                                                  (match-define (work f t) w)
+                                                  (string-append f ": " (symbol->string t)))
+                                                ", ")))
   (for/list ([_ (in-range num-procs)])
     (thread do-next)))
 
diff --git a/pkgs/redex-pkgs/redex-examples/redex/examples/benchmark/test-file.rkt b/pkgs/redex-pkgs/redex-examples/redex/examples/benchmark/test-file.rkt
index b61c1a1e72..e020076d2f 100644
--- a/pkgs/redex-pkgs/redex-examples/redex/examples/benchmark/test-file.rkt
+++ b/pkgs/redex-pkgs/redex-examples/redex/examples/benchmark/test-file.rkt
@@ -58,6 +58,22 @@
                                     (last (regexp-split #rx"/" filename))))
                      "-results.rktd")))
 
+(define (with-timeout time thunk fail-thunk)
+  (define res-chan (make-channel))
+  (define exn-chan (make-channel))
+  (define thd (thread (λ () 
+                        (with-handlers ([exn:fail? (λ (exn) (channel-put exn-chan exn))])
+                          (channel-put res-chan (thunk))))))
+  (sync
+   (handle-evt (alarm-evt (+ (current-inexact-milliseconds) time))
+               (λ (_) 
+                 (break-thread thd)
+                 (fail-thunk)))
+   (handle-evt exn-chan
+               (λ (exn) (raise exn)))
+   (handle-evt res-chan
+               (λ (result-of-thunk) result-of-thunk))))
+
 (define (run-generations fname verbose? no-errs? get-gen check seconds type)
   (collect-garbage)
   (define s-time (current-process-milliseconds))
@@ -74,9 +90,16 @@
                       (+ i terms) tot-time (exact->inexact (/ (+ i terms) (/ tot-time 1000)))))
          (void)]
         [else
-         (define term (g))
+         (define term (with-timeout (* 5 60 60) g 
+                                    (λ () (printf "\nTimed out generating a test term in: ~a, ~a\n"
+                                                  fname type)
+                                      (displayln i)
+                                      (loop (add1 i)))))
          (define me-time (- (current-process-milliseconds) t-time))
-         (define ok? (check term))
+         (define ok? (with-timeout (* 5 60 60) (λ () (check term))
+                                   (λ () (printf "\nIn ~a, ~a, timed out checking the term:~a\n"
+                                                 fname type term)
+                                     (loop (add1 i)))))
          (cond
            [(not ok?)
             (when verbose?