check-syntax benchmark

bm.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 (get-input-port src)
  (define in (open-input-file src))
  (port-count-lines! in)
  in)

(define (read-expanded-syntax in)
  (define base-ns (make-base-namespace))

  (parameterize ([current-load-relative-directory src-dir]
                 [current-namespace base-ns])
    (define stx (with-module-reading-parameterization
                  (lambda () (read-syntax src in))))
    (expand stx)))

(define (traversal expanded-stx make-traversal)
  (define base-ns (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%))

  (parameterize ([current-namespace base-ns]
                 [current-annotations collector])
    (add-syntax expanded-stx)
    (done)))

(define (test make-traversal)
  (collect-garbage)

  (displayln 'expand)
  (define in (get-input-port src))
  (define expanded (time (read-expanded-syntax in)))

  (collect-garbage)

  (displayln 'traversal)
  (time (traversal expanded make-traversal)))

(test make-traversal)