profile check-syntax

tracker.rkt

#lang racket

(require syntax/modread
         racket/cmdline
         drracket/check-syntax)

(define filename (command-line #:args (filename) filename))

(define src (path->complete-path (string->path filename)))
(define-values (src-dir _1 _2) (split-path src))
(define in (open-input-file src))
(define in2 (open-input-file src))
(displayln (format "file: ~a" src))

(port-count-lines! in)
(port-count-lines! in2)

(collect-garbage)

(define base-ns (make-base-namespace))

(define expanded
  (parameterize ([current-load-relative-directory src-dir]
                 [current-namespace base-ns])
    (displayln 'read-syntax)
    (define stx1 (time (with-module-reading-parameterization
                         (lambda () (read-syntax src in)))))

    (collect-garbage)

    (displayln '|read-syntax 2nd|)
    (define stx2 (time (with-module-reading-parameterization
                         (lambda () (read-syntax src in2)))))

    (collect-garbage)

    (displayln 'expand)
    (time (expand stx1))

    (collect-garbage)

    (displayln '|expand 2nd|)
    (time (expand stx2))))

(collect-garbage)

(define base-ns1 (make-base-namespace))

(define-values (add-syntax done)
  (make-traversal base-ns #f))

(define collector%
  (class (annotations-mixin object%)
    (super-new)

    (define/override (syncheck:find-source-object stx)
      (if (equal? (syntax-source stx) src)
          src
          #f))))

(define collector (new collector%))

(displayln 'traversal)
(time (parameterize ([current-namespace base-ns1]
                     [current-annotations collector])
        (add-syntax expanded)
        (done)))

(collect-garbage)

(define base-ns2 (make-base-namespace))

(define-values (add-syntax2 done2)
  (make-traversal base-ns #f))

(displayln '|traversal 2nd|)
(time (parameterize ([current-namespace base-ns2]
                     [current-annotations collector])
        (add-syntax2 expanded)
        (done2)))