From 87f4796adbbfc92fcacbc299bb2867b4b7ade4e4 Mon Sep 17 00:00:00 2001 From: Ben Greenman Date: Fri, 10 Jun 2016 15:57:33 -0400 Subject: [PATCH] [private] track misses and hits in optimization --- trivial/private/common.rkt | 9 ++-- trivial/private/raco-command.rkt | 88 +++++++++++++++++++++----------- 2 files changed, 64 insertions(+), 33 deletions(-) diff --git a/trivial/private/common.rkt b/trivial/private/common.rkt index 8cd8d5d..adb25b1 100644 --- a/trivial/private/common.rkt +++ b/trivial/private/common.rkt @@ -97,8 +97,9 @@ (lambda (stx) (syntax-parse stx #:literals (tr:#%plain-lambda) [(_ name:id v) - #:with (tr:#%plain-lambda (_) v+) - (expand-expr (syntax/loc stx (tr:lambda (name) v))) + #:with v+ + (parameterize ([*STOP-LIST* (cons (syntax/loc stx name) (*STOP-LIST*))]) + (expand-expr (syntax/loc stx v))) #:when (syntax-e (syntax/loc stx v+)) #:with m (f-parse (syntax/loc stx v+)) #:when (syntax-e (syntax/loc stx m)) @@ -133,9 +134,10 @@ (cond [(parser stx) => (lambda (r) - (when (*TRIVIAL-LOG*) (log stx "alias ~a" (syntax->datum id-stx))) + (when (*TRIVIAL-LOG*) (log stx "HIT ~a" (syntax->datum id-stx))) r)] [else + (when (*TRIVIAL-LOG*) (log stx "MISS ~a" (syntax->datum id-stx))) (syntax-parse stx [_:id id-stx] @@ -146,7 +148,6 @@ (define ((make-keyword-alias id-sym parser) stx) (or (with-handlers ((exn:fail? (lambda (e) #f))) (parser stx)) ;; 2016-06-08: sometimes parser raises error ... i.e. "unbound local member name" - (parser stx) (syntax-parse stx [(_ e* ...) #:with id-stx (case id-sym diff --git a/trivial/private/raco-command.rkt b/trivial/private/raco-command.rkt index a0d7dad..3746af0 100644 --- a/trivial/private/raco-command.rkt +++ b/trivial/private/raco-command.rkt @@ -10,13 +10,18 @@ ;; - automatically (require trivial) ;; - work for typed OR untyped files +(provide + collect-and-summarize +) + (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/format ~a ~r) + (only-in racket/list last) + (only-in racket/string string-split string-prefix? string-contains?) (only-in racket/system process) + racket/path + syntax/modread ) ;; ============================================================================= @@ -34,15 +39,23 @@ (define (log->data ln) (string->symbol (last (string-split ln)))) -(define (summarize fname H) - (summarize-sexp fname H)) +(define (rnd n) + (~r n #:precision '(= 2))) -(define (summarize-sexp fname H) +(define (summarize fname H M) + (summarize-sexp fname H M)) + +(define (summarize-sexp fname H M) (printf "(~a" fname) (define-values (kv* pad-to) (hash->kv+pad H)) (for ([kv (in-list (sort kv* > #:key cdr))]) + (define k (car kv)) + (define num-hits (cdr kv)) + (define num-miss (hash-ref M k 0)) + (define total (+ num-hits num-miss)) + (define pct (rnd (* 100 (/ num-hits total)))) (newline) - (printf " (~a\t~a)" (~a (car kv) #:min-width pad-to) (cdr kv))) + (printf " (~a\t~a\t~a\t~a)" (~a k #:min-width pad-to) num-hits num-miss pct)) (printf ")\n")) (define (summarize-ascii H) @@ -76,43 +89,51 @@ [else (void)])) -(module+ main - (require - racket/cmdline - syntax/modread) - (command-line - #:once-each - [("--clean" "--all") "Make clean before running" (*ANNIHILATE* #t)] - #:args (fname) +(define (hit? line) + (string-contains? line "HIT")) + +(define (miss? line) + (string-contains? line "MISS")) + +(define (make-counter) + (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 (collect-and-summarize 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-values (H H++) (make-counter)) + (define-values (M M++) (make-counter)) (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))] + (cond + [(miss? line) + (M++ (log->data line))] + [else + (H++ (log->data line))] + #;[else + (printf "WARNING: error parsing log message ~a\n" line)])] [else (void)]))) (let loop () (case (check-status 'status) [(running) - (debug "Subprocess running, reading output so far") + #;(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))] + #;(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))) @@ -122,8 +143,17 @@ (close-output-port out) (close-input-port err) ;; -- - (summarize fname H) -)) + (summarize fname H M)) + +;; ----------------------------------------------------------------------------- + +(module+ main + (require racket/cmdline) + (command-line + #:once-each + [("--clean" "--all") "Make clean before running" (*ANNIHILATE* #t)] + #:args (fname) + (collect-and-summarize fname))) ;; ----------------------------------------------------------------------------- ;; -- trash