diff --git a/trivial/info.rkt b/trivial/info.rkt index 495560d..f74f0c5 100644 --- a/trivial/info.rkt +++ b/trivial/info.rkt @@ -18,3 +18,4 @@ (define version "1") (define pkg-authors '(ben)) (define scribblings '(("scribblings/trivial.scrbl" () ("typed-racket")))) +(define raco-commands '(("trivial" (submod trivial/private/command-line main) "Compile and log optimizations" #f))) diff --git a/trivial/private/command-line.rkt b/trivial/private/command-line.rkt new file mode 100644 index 0000000..538ce25 --- /dev/null +++ b/trivial/private/command-line.rkt @@ -0,0 +1,131 @@ +#lang racket/base + +;; Usage: +;; raco trivial FILE.rkt +;; If file has the *TRIVIAL-LOG* parameter set at phase 1, +;; this file will report all the optimizations that took place in it. + +;; TODO +;; - automatically set LOG parameter +;; - automatically (require trivial) +;; - work for typed OR untyped files + +(require + (only-in racket/string string-split string-prefix?) + (only-in racket/list last) + racket/path + (only-in racket/format ~a) + (only-in racket/file delete-directory/files) + (only-in racket/system process) +) + +;; ============================================================================= + +(define TRIVIAL-LOG-PREFIX "[LOG]") + +(define *ANNIHILATE* (make-parameter #f)) + +(define-syntax-rule (debug msg arg* ...) + (begin + (display "[DEBUG] ") + (printf msg arg* ...) + (newline))) + +(define (log->data ln) + (string->symbol (last (string-split ln)))) + +(define (summarize H) + (define msg "Summary of trivial HITS:") + (displayln msg) + (displayln (make-string (string-length msg) #\=)) + (define-values (kv* pad-to) + (for/fold ([acc '()] + [pad-to 0]) + ([(k v) (in-hash H)]) + (values (cons (cons k v) acc) (max pad-to (string-length (symbol->string k)))))) + (for ([kv (in-list (sort kv* > #:key cdr))]) + (displayln (string-append + "- " + (~a (car kv) #:min-width pad-to) + "\t" + (number->string (cdr kv)))))) + +(define (remove-compiled ps) + (define c-dir (build-path (path-only ps) "compiled")) + (define fname (path-replace-extension (file-name-from-path ps) "_rkt.zo")) + (define c-file (build-path c-dir fname)) + (cond + [(*ANNIHILATE*) + (delete-directory/files c-dir #:must-exist? #f)] + [(and (directory-exists? c-dir) + (file-exists? c-file)) + (delete-file c-file)] + [else + (void)])) + +(module+ main + (require + racket/cmdline + syntax/modread) + (command-line + #:once-each + [("--clean" "--all") "Make clean before running" (*ANNIHILATE* #t)] + #:args (fname) + (remove-compiled fname) + (define cmd (format "raco make ~a" fname)) + (define-values (in out pid err check-status) (apply values (process cmd))) + (define-values (H H++) + (let* ([H (make-hasheq)] + [H++ (lambda (k) + (define old (hash-ref H k (lambda () #f))) + (if old + (hash-set! H k (+ old 1)) + (hash-set! H k 1)))]) + (values H H++))) + (define num-lines (box 0)) + (define (subprocess-read) + (for ([line (in-lines in)]) + (set-box! num-lines (+ 1 (unbox num-lines))) + (cond + [(string-prefix? line TRIVIAL-LOG-PREFIX) + (H++ (log->data line))] + [else + (void)]))) + (let loop () + (case (check-status 'status) + [(running) + (debug "Subprocess running, reading output so far") + (subprocess-read) + (loop)] + [(done-ok) + (subprocess-read) + (debug "Subprocess finished cleanly. Produced ~a lines of output." (unbox num-lines))] + [(done-error) + (parameterize ([current-output-port (current-error-port)]) + (for ([line (in-lines err)]) (displayln line))) + (raise-user-error 'trace "Subprocess '~a' exited with an error" cmd)])) + ;; -- close pipe ports + (close-input-port in) + (close-output-port out) + (close-input-port err) + ;; -- + (summarize H) +)) + +;; ----------------------------------------------------------------------------- +;; -- trash + +;(require +; (for-syntax racket/base (only-in trivial/parameters *TRIVIAL-LOG*))) +;(begin-for-syntax (*TRIVIAL-LOG* #t)) +; +;(define-namespace-anchor nsa) +;(define ns (namespace-anchor->namespace nsa)) + + + ;(with-module-reading-parameterization + ; (lambda () + ; (call-with-input-file fname + ; (lambda (port) + ; (parameterize ([current-namespace ns]) + ; (void (compile (read-syntax fname port))))))))