compile.rkt

#lang racket

(require compiler/cm mzlib/compile unstable/logging)

(manager-compile-notify-handler displayln) 

(define prefix "/home/samth/sw/plt/collects/tests/typed-racket/succeed/")


(define (del file)
  (with-handlers ([void void])
    (delete-file (string-append prefix "compiled/" file "_rkt.zo"))))

(define (record file)
  (define l (start-recording 'debug 'timing))
  (parameterize ((read-accept-reader #t)
                 (current-namespace (make-base-namespace)))  
    (del file)
    (compile-file (string-append prefix file ".rkt"))
    (del file))
  (map (λ (v) (vector-ref v 2)) (stop-recording l)))


(struct tr-event (start? time msg) #:prefab)

(struct stree (name start time) #:transparent)
(struct tree stree (self children) #:transparent)

(define (mk-tree n s t c self)
  (if (empty? c) (stree n s t) (tree n s t self c)))

(define total-self 0)

(define (build-tree events current-tree)
  (define current-tree-name (stree-name current-tree))  
  (match-define (tr-event next-start? next-time next-message) (car events))
  (when (null? events) (error 'fail)) ;; didn't finish the current tree
  (cond [(and (equal? next-message current-tree-name) (not next-start?))
         ;; finish the current tree
         (values (mk-tree current-tree-name (stree-start current-tree)
                          next-time (tree-children current-tree)
                          (let ([s (- next-time
                                      (for/sum ([t (tree-children current-tree)])
                                        (stree-time t)))])
                            (unless (empty? (tree-children current-tree))
                              (set! total-self (+ total-self s)))
                            s))
                 (cdr events))]
        ;; the next event must start something
        [(not next-start?) (error 'whoops)]
        ;; we start the next tree
        [else 
         (define new-tree (tree next-message next-time #f #f empty))
         (define-values (next-tree remaining-events) (build-tree (rest events) new-tree))
         (build-tree
          remaining-events
          (tree current-tree-name
                (stree-start current-tree)
                (stree-time current-tree)
                #f
                (append (tree-children current-tree) (list next-tree))))]))

(define (process events)
  (define t
    (let loop ([events events])
      (cond [(empty? events)
             events]
            [else
             (define fst (car events))
             (define-values (x y) (build-tree (cdr events) (tree (tr-event-msg fst) (tr-event-time fst) #f #f empty)))
             (cons x (loop y))])))
  t)



(define (go file)  (process (record file)))

(module+ main
  (command-line #:args (file)
                (pretty-print (go file))
                (printf "total missed: ~a\n" total-self)))