suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

redex: parallelize benchmark generation modes

Browse Source 
also, add a timeout (currently 5 mins)
This commit is contained in:
Burke Fetscher 2014-02-25 17:11:17 -06:00
parent e4ce0d0331
commit 3e83a816e2
2 changed files with 52 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
pkgs/redex-pkgs/redex-examples/redex/examples/benchmark/run-muts.rkt
View File

@ -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)))

27
pkgs/redex-pkgs/redex-examples/redex/examples/benchmark/test-file.rkt
View File

@ -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?