diff --git a/collects/typed-scheme/core.rkt b/collects/typed-scheme/core.rkt index 6113e7a3..deab5b85 100644 --- a/collects/typed-scheme/core.rkt +++ b/collects/typed-scheme/core.rkt @@ -31,11 +31,11 @@ (;; pmb = #%plain-module-begin [(pmb . body2) new-mod] ;; perform the provide transformation from [Culpepper 07] - [transformed-body (remove-provides #'body2)] + [transformed-body (begin0 (remove-provides #'body2) (do-time "Removed provides"))] ;; add the real definitions of contracts on requires - [transformed-body (change-contract-fixups #'transformed-body)] + [transformed-body (begin0 (change-contract-fixups #'transformed-body) (do-time "Fixed contract ids"))] ;; potentially optimize the code based on the type information - [(optimized-body ...) (maybe-optimize #'transformed-body)] + [(optimized-body ...) (maybe-optimize #'transformed-body)] ;; has own call to do-time ;; add in syntax property on useless expression to draw check-syntax arrows [check-syntax-help (syntax-property (syntax-property diff --git a/collects/typed-scheme/tc-setup.rkt b/collects/typed-scheme/tc-setup.rkt index e8dd1060..1e051e89 100644 --- a/collects/typed-scheme/tc-setup.rkt +++ b/collects/typed-scheme/tc-setup.rkt @@ -4,7 +4,6 @@ (except-in syntax/parse id) unstable/mutated-vars racket/pretty - scheme/base (optimizer optimizer) (private type-contract) (types utils convenience) @@ -35,7 +34,7 @@ (define-syntax-rule (tc-setup orig-stx stx expand-ctxt fully-expanded-stx checker result . body) (let () (set-box! typed-context? #t) - (start-timing (syntax-property stx 'enclosing-module-name)) + ;(start-timing (syntax-property stx 'enclosing-module-name)) (with-handlers ([(lambda (e) (and #f (exn:fail? e) (not (exn:fail:syntax? e)))) (lambda (e) (tc-error "Internal Typed Racket Error : ~a" e))]) @@ -68,6 +67,7 @@ [orig-module-stx (or (orig-module-stx) orig-stx)] [expanded-module-stx fully-expanded-stx] [debugging? #f]) + (do-time "Starting `checker'") (let ([result (checker fully-expanded-stx)]) (do-time "Typechecking Done") (let () . body)))))))) diff --git a/collects/typed-scheme/typed-scheme.rkt b/collects/typed-scheme/typed-scheme.rkt index 1552b7f5..a60231ad 100644 --- a/collects/typed-scheme/typed-scheme.rkt +++ b/collects/typed-scheme/typed-scheme.rkt @@ -1,6 +1,7 @@ #lang racket/base (require (for-syntax racket/base + "utils/utils.rkt" ;; only for timing/debugging ;; these requires are needed since their code ;; appears in the residual program "typecheck/renamer.rkt" "types/type-table.rkt")) @@ -16,18 +17,28 @@ (define-for-syntax initialized #f) (define-for-syntax (do-standard-inits) (unless initialized + (do-time "Starting initialization") ((dynamic-require 'typed-scheme/base-env/base-structs 'initialize-structs)) - ((dynamic-require 'typed-scheme/base-env/base-env-indexing 'initialize-indexing)) - ((dynamic-require 'typed-scheme/base-env/base-env 'init)) - ((dynamic-require 'typed-scheme/base-env/base-env-numeric 'init)) + (do-time "Finshed base-structs") + ((dynamic-require 'typed-scheme/base-env/base-env-indexing 'initialize-indexing)) + (do-time "Finshed base-env-indexing") + ((dynamic-require 'typed-scheme/base-env/base-env 'init)) + (do-time "Finshed base-env") + ((dynamic-require 'typed-scheme/base-env/base-env-numeric 'init)) + (do-time "Finshed base-env-numeric") ((dynamic-require 'typed-scheme/base-env/base-special-env 'initialize-special)) + (do-time "Finished base-special-env") (set! initialized #t))) (define-syntax-rule (drivers [name sym] ...) (begin (define-syntax (name stx) + (do-time (format "Calling ~a driver" 'name)) (do-standard-inits) - ((dynamic-require 'typed-scheme/core 'sym) stx)) + (define f (dynamic-require 'typed-scheme/core 'sym)) + (do-time (format "Loaded core ~a" 'sym)) + (begin0 (f stx) + (do-time "Finished, returning to Racket"))) ...)) (drivers [module-begin mb-core] [top-interaction ti-core] [with-type wt-core]) diff --git a/collects/typed-scheme/utils/utils.rkt b/collects/typed-scheme/utils/utils.rkt index 5acf1fa2..0ed49bfa 100644 --- a/collects/typed-scheme/utils/utils.rkt +++ b/collects/typed-scheme/utils/utils.rkt @@ -106,27 +106,36 @@ at least theoretically. ;; some macros to do some timing, only when `timing?' is #t (define-for-syntax timing? #f) -(define last-time (make-parameter #f)) +(define last-time #f) (define initial-time #f) +(define (set!-initial-time t) (set! initial-time t)) +(define (set!-last-time t) (set! last-time t)) +(define (pad str len pad-char) + (define l (string-length str)) + (if (>= l len) + str + (string-append str (make-string (- len l) pad-char)))) (define-syntaxes (start-timing do-time) (if timing? (values (syntax-rules () [(_ msg) (begin - (when (last-time) - (error #f "Timing already started")) - (last-time (current-process-milliseconds)) - (printf "Starting ~a at ~a\n" msg (last-time)))]) + (when last-time + (error 'start-timing "Timing already started")) + (set!-last-time (current-process-milliseconds)) + (set!-initial-time last-time) + (log-debug (format "TR Timing: ~a at ~a" (pad "Starting" 40 #\space) initial-time)))]) (syntax-rules () [(_ msg) (begin - (unless (last-time) + (unless last-time (start-timing msg)) (let* ([t (current-process-milliseconds)] - [old (last-time)] - [diff (- t old)]) - (last-time t) - (printf "Timing ~a at ~a@~a\n" msg diff t)))])) + [old last-time] + [diff (- t old)] + [new-msg (pad msg 40 #\space)]) + (set!-last-time t) + (log-debug (format "TR Timing: ~a at ~a\tlast step: ~a\ttotal: ~a" new-msg t diff (- t initial-time)))))])) (values (lambda _ #'(void)) (lambda _ #'(void))))) ;; custom printing