drdr/time.rkt at master · racket/drdr · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
#lang racket/base
(require racket/cmdline
         racket/list
         job-queue
         racket/system
         "config.rkt"
         "notify.rkt"
         "dirstruct.rkt"
         "sema.rkt"
         "cache.rkt")

(define test-workers (make-job-queue (number-of-cpus)))

(define start-revision #f)
(define history? #f)

(command-line #:program "time"
              #:once-each
              ["-H" "Run on all revisions"
                    (set! history? #t)]
              ["-r" rev
                    "Start with a particular revision"
                    (set! start-revision (string->number rev))])

(unless start-revision
  (init-revisions!)
  (set! start-revision (newest-revision)))

(define count-sema (make-semaphore 0))

(define (make-log! filename)
  (submit-job!
   test-workers
   (lambda ()
     (notify! "Dropping timing for ~a" filename)
     (apply
      system*/exit-code
      (path->string
       (build-path (plt-directory) "plt" "bin" "racket"))
      "-t"
      (path->string (build-path (drdr-directory) "time-file.rkt"))
      "--"
      (append
       (if history?
           (list "-H")
           (list "-r" (number->string start-revision)))
       (list
        (path->string filename))))
     (notify! "Done with ~a" filename)
     (semaphore-post count-sema))))

(define (find-files p l)
  (for/fold ([i 0])
    ([f (in-list (cached-directory-list* p))])
    (define fp (build-path p f))
    (define fl (list* f l))
    (if (cached-directory-exists? fp)
        (+ i (find-files fp fl))
        (begin (make-log! (apply build-path (reverse fl)))
               (add1 i)))))

(define how-many-files
  (find-files (revision-log-dir start-revision)
              empty))

(semaphore-wait* count-sema how-many-files)

(stop-job-queue! test-workers)