1#lang racket/base
2(require racket/list
3         racket/match
4         racket/dict
5         racket/set
6         racket/string
7         racket/format
8         racket/cmdline
9         (rename-in racket/match [match-define defmatch])
10         racket/pretty
11         raco/command-name
12         syntax/id-table
13         syntax/modresolve
14         syntax/modcode
15         setup/collects ;; setup/path-to-relative
16         macro-debugger/model/deriv
17         macro-debugger/model/deriv-util
18         "private/util.rkt")
19(provide (all-defined-out))
20
21;; term-size : Syntaxish -> Nat
22;; Rough measure of the size of a term.
23(define term-size
24  (let ([memo (make-weak-hasheq)])
25    (lambda (x)
26      (hash-ref! memo x
27                 (lambda ()
28                   (cond [(syntax? x) (term-size (syntax-e x))]
29                         [(pair? x) (+ 1 (term-size (car x)) (term-size (cdr x)))]
30                         [(vector? x)
31                          (+ 1 (for/sum ([y (in-vector x)]) (term-size y)))]
32                         [(prefab-struct-key x)
33                          (+ 1 (for/sum ([y (in-vector (struct->vector x) 1)])
34                                 (term-size y)))]
35                         [(box? x)
36                          (+ 1 (term-size (unbox x)))]
37                         [(hash? x)
38                          (+ 1 (for/sum ([(k v) (in-hash x)])
39                                 (+ (term-size k) (term-size v))))]
40                         [else 1]))))))
41
42(define (sqr x) (* x x))
43
44(define (push! b x) (set-box! b (cons x (unbox b))))
45
46;; enclosing-modpath : Parameterof ModulePath/#f
47(define enclosing-modpath (make-parameter #f))
48
49;; nice-modpath : ModulePath/ModulePathIndex [Datum/#f] -> Datum
50(define (nice-modpath mod)
51  (define rmp0
52    (cond [(module-path-index? mod)
53           (unless (enclosing-modpath)
54             (error 'nice-modpath "enclosing modpath not set"))
55           (resolve-module-path-index mod (enclosing-modpath))]
56          [else (resolve-module-path mod)]))
57  (let loop ([rmp rmp0])
58    (match rmp
59      [(? path?)
60       (match (path->collects-relative rmp #:cache nice-modpath-cache)
61         [(list* 'collects parts)
62          (define (bytes->string b) (path->string (bytes->path b)))
63          `(lib ,(string-join (map bytes->string parts) "/"))]
64         [(? path? p) (path->string p)])]
65      [(? symbol?) `(quote ,rmp)]
66      [(list* 'submod "." submodnames)
67       (match (and (enclosing-modpath) (nice-modpath (enclosing-modpath)))
68         [(list* 'submod enc-base enc-submodnames)
69          `(submod ,enc-base ,@(append enc-submodnames submodnames))]
70         [(? values enc-base)
71          `(submod ,enc-base ,@submodnames)]
72         [#f (error 'nice-modpath "relative submod path: ~e => ~e" mod rmp)])]
73      [(list* 'submod ".." submodnames)
74       (error 'nice-modpath "relative (up) submod path: ~e => ~e" mod rmp)]
75      [(list* 'submod base submodnames)
76       `(submod ,(loop base) ,@submodnames)]
77      [_
78       (eprintf "nice-modpath: ~e, ~e\n" mod (enclosing-modpath))
79       (eprintf "  rmp0 = ~e\n" rmp0)
80       (eprintf "  rmp  = ~e\n" rmp)
81       (error 'nice-modpath "invalid")])))
82
83(define nice-modpath-cache (make-hash))
84
85;; ============================================================
86;; Raw Data Collection
87
88;; A moc (macro occurrence) is (moc Context Nat Nat Integer)
89(struct moc (ctx init-size final-size adj) #:prefab)
90(define (moc-phase m) (fr-phase (car (moc-ctx m))))
91
92;; adj is adjustment for local expansion, usually negative
93
94;; Context is (listof Frame); Frame is (fr Id Nat)
95;; (list (fr m2 0) (fr m1 0)) means an expansion of m2 at phase 0,
96;; where the reference was produced by m1 at phase 0, which (probably)
97;; occurred in the original program
98(struct fr (id phase) #:prefab)
99
100(define (fr=? f1 f2)
101  (match* [f1 f2]
102    [[(fr id1 ph1) (fr id2 ph2)]
103     (and (= ph1 ph2) (free-identifier=? id1 id2 ph1))]))
104(define (fr-hash-code f)
105  (match f [(fr id ph) (+ ph (equal-hash-code (identifier-binding-symbol id ph)))]))
106
107(define (context? v) (and (list? v) (andmap fr? v)))
108(define (context=? ctx1 ctx2)
109  (and (= (length ctx1) (length ctx2)) (andmap fr=? ctx1 ctx2)))
110(define (context-hash-code ctx)
111  (apply + (map fr-hash-code ctx)))
112
113(define-custom-hash-types fr-hash #:key? fr?
114  fr=? fr-hash-code)
115(define-custom-hash-types ctx-hash #:key? context?
116  context=? context-hash-code)
117
118;; ----------------------------------------
119
120;; A ScopeTable is Hash[ScopeInt => Context]
121
122;; get-new-scope : Syntax Syntax Nat -> ScopeInt
123(define (get-new-scope x mx phase)
124  (define xi (get-macro-scopes x phase))
125  (define mxi (get-macro-scopes mx phase))
126  (define diff (set-subtract mxi xi))
127  (match diff
128    [(list scope) scope]
129    [_ (error 'get-new-scope "bad scopes diff: ~e" diff)]))
130
131;; get-macro-scopes : Syntax Nat -> (listof ScopeInt)
132(define (get-macro-scopes x phase)
133  (append* (for/list ([ph (in-range (add1 phase))])
134             (for/list ([v (in-list (hash-ref (syntax-debug-info x ph) 'context))]
135                        #:when (eq? (vector-ref v 1) 'macro))
136               (vector-ref v 0)))))
137
138;; get-macro-scope : Syntax ScopeTable Nat -> ScopeInt/#f
139;; Returns the last macro scope present in the table.
140(define (get-macro-scope x h phase)
141  (define mscopes (sort (get-macro-scopes x phase) >))
142  (for/first ([mscope (in-list mscopes)] #:when (hash-ref h mscope #f))
143    mscope))
144
145;; ----------------------------------------
146
147;; phase : (Parameterof Nat)
148(define phase (make-parameter 0))
149
150;; moc-box : Parameterof (Boxof MOC)
151(define moc-box (make-parameter #f))
152
153;; profile/top : Deriv -> (Listof MOC)
154(define (profile/top deriv)
155  (define mocs (box null))
156  (parameterize ((phase 0))
157    (profile/deriv deriv mocs (make-hash)))
158  (unbox mocs))
159
160;; profile/deriv : Derivation (Boxof MOC) -> Void
161;; Record size deltas from all macro steps of deriv in profinfo.
162(define (profile/deriv deriv mocs scope=>context)
163  (define (recur . ds)
164    (for ([d (in-list ds)])
165      (cond [(list? d) (for-each recur d)]
166            [else (profile/deriv d mocs scope=>context)])))
167  (define (recur/phase-up . ds)
168    (parameterize ((phase (add1 (phase)))) (recur ds)))
169  ;; Handle individual variants
170  (#%expression
171    (match deriv
172      ;; ====
173      [(mrule z1 z2 rs de1 ?1 me1 locals me2 ?2 etx retx next)
174       (define macro-id (and (pair? rs) (resolves->macro-id rs (phase))))
175       (define macro-scope (and z1 me1 (get-new-scope z1 me1 (phase))))
176       (define z1-scope (get-macro-scope z1 scope=>context (phase)))
177       (define context (hash-ref scope=>context z1-scope null))
178       (define context* (cons (fr macro-id (phase)) context))
179       (when (and macro-id macro-scope)
180         (hash-set! scope=>context macro-scope context*))
181       (recur locals next)
182       (when macro-id
183         (define adj (apply + (map profile/local (or locals null))))
184         (push! mocs (moc context* (term-size z1) (term-size retx) adj))
185         (when #f
186           (eprintf "* macro-id ~e\n" macro-id)
187           (eprintf "  ctx = ~e\n" context)
188           (eprintf "  from (~s): ~e\n" (term-size z1) (syntax->datum z1))
189           (eprintf "  to   (~s): ~e\n" (term-size retx) (syntax->datum retx))
190           (unless (zero? adj)
191             (eprintf "  with local adjustment: ~s\n" adj))))]
192      ;; ====
193      [(p:letrec-syntaxes+values z1 _ rs de1 _ srenames prep sbindrhss vrhss body)
194       (recur prep sbindrhss vrhss body)
195       (when #t ;; syntax bindings get dropped
196         (define rhss-size
197           (for/sum ([bind (in-list (or sbindrhss null))])
198             (+ (term-size (node-z2 (bind-syntaxes-rhs bind)))
199                ;; 2 for (svars . (srhs . ())) pairs
200                ;; FIXME: also count svars term-size (in srename?)
201                2)))
202         (define lsv-id (and (pair? rs) (resolves->macro-id rs (phase))))
203         (define z1-scope (get-macro-scope z1 scope=>context (phase)))
204         (define context (hash-ref scope=>context z1-scope null))
205         (define context* (cons (fr lsv-id (phase)) context))
206         (when lsv-id
207           (push! mocs (moc context* 0 0 (- rhss-size)))
208           (when #f
209             (eprintf "* lsv-id-id = ~e\n" lsv-id)
210             (eprintf "  ctx       = ~e\n" context))))]
211      ;; ====
212      ;; Otherwise, recur through children
213      [deriv (for-subnodes deriv #:recur recur #:recur/phase-up recur/phase-up)])))
214
215
216;; profile/local : LocalAction -> Integer
217;; Adjustment to mrule's delta due to local actions.
218(define (profile/local l)
219  (define adj
220    (match l
221      [(local-expansion z1 z2 for-stx? me1 inner lifted me2 opaque)
222       ;; Assume z1 is from macro args, z2 appears in macro result.
223       ;; Then macro is not responsible for the difference, so *subtract*
224       ;; the delta z2-z1; equivalently, add z1-z2.
225       (- (term-size z1) (term-size z2))]
226      [(local-lift-expr ids orig renamed) ;; (define-values [] []) : 5 nodes
227       (+ (term-size orig) (term-size ids))]
228      [(local-lift-end orig renamed wrapped)
229       (term-size orig)]
230      [(local-lift-require req expr mexpr) ;; (require []) : 4 nodes
231       (+ 4 (term-size req))]
232      [(local-lift-provide prov) ;; (provide []) : 4 nodes
233       (+ 4 (term-size prov))]
234      [_ ;; local-value, local-bind, etc
235       0]))
236  (when #f
237    (unless (zero? adj)
238      (eprintf "! adjust by ~s for ~e\n" adj l)))
239  adj)
240
241(define (resolves->macro-id rs phase)
242  ;; For application, want #%app, not procedure name; this might not
243  ;; be optimal for rename-transformers, though.
244  (define mlast (last rs))
245  (for/first ([id (in-list rs)] #:when (free-identifier=? id mlast phase)) id))
246
247;; ============================================================
248;; Processing
249
250;; ProfInfo =
251;;   (profinfo Dict[Frame => (Listof Integer)] Dict[Frame => Integer] Integer Integer)
252(struct profinfo (init-size final-size mocs) #:mutable)
253
254(define (new-profinfo) (profinfo 0 0 null))
255
256(define (profinfo-update! pi init-size final-size mocs)
257  (set-profinfo-init-size! pi (+ (profinfo-init-size pi) init-size))
258  (set-profinfo-final-size! pi (+ (profinfo-final-size pi) final-size))
259  (set-profinfo-mocs! pi (append mocs (profinfo-mocs pi))))
260
261;; print-profinfo : ProfInfo
262;;                  #:sort (U 'total 'direct 'totalmean 'directmean)
263;;                  #:excludes (Listof (Id Nat -> Boolean))
264;;               -> Void
265(define (print-profinfo pr
266                        #:sort [sort-order 'total]
267                        #:excludes [excludes null])
268  (match-define (profinfo init-size final-size mocs) pr)
269  (printf "Initial code size: ~s\n" init-size)
270  (printf "Final code size  : ~s\n" final-size)
271  (printf "========================================\n")
272  (define phases (hash-keys (for/hash ([m (in-list mocs)]) (values (moc-phase m) #t))))
273  (for ([phase (in-list (sort phases <))])
274    (define entries (mocs->profile-entries mocs phase))
275    (printf "Phase ~s\n" phase)
276    (for-each print-entry (sort entries > #:key (sort-order->key sort-order)))
277    (printf "----------------------------------------\n\n")))
278
279;; ProfileEntry[K] = (list K IndirectStats DirectStats)
280;; DirectStats = (list Integer Integer Nat Nat Real)
281;;   -- total, mean (rounded), count, stddev
282;; An IndirectStats is Integer -- total
283(define (pe->total pe) (second pe))
284(define (pe->direct pe) (first (third pe)))
285(define (pe->count pe) (third (third pe)))
286(define (pe->totalmean pe) (/ (pe->total pe) (pe->count pe)))
287(define (pe->directmean pe) (/ (pe->direct pe) (pe->count pe)))
288
289;; mocs->profile-entries : (Listof MOC) -> (Listof ProfileEntry)
290(define (mocs->profile-entries mocs phase)
291  (define direct-d (make-mutable-fr-hash))
292  (define indirect-d (make-mutable-fr-hash))
293  (for ([m (in-list mocs)] #:when (= (moc-phase m) phase))
294    (match-define (moc ctx init-size final-size adj) m)
295    (match-define (cons fr0 ctx*) ctx)
296    (define delta (+ (- final-size init-size) adj))
297    (dict-set! direct-d fr0 (cons delta (dict-ref direct-d fr0 null)))
298    (for ([f (in-list (remove-duplicates ctx fr=?))])
299      (dict-set! indirect-d f (+ (dict-ref indirect-d f 0) delta))))
300  (for/list ([(f directs) (in-dict direct-d)])
301    (define indirect (dict-ref indirect-d f 0))
302    (list f indirect (deltas->direct-stats directs))))
303
304;; deltas->direct-stats : (Listof Integer) -> (List Int Int Nat Real)
305(define (deltas->direct-stats deltas)
306  (define sum (apply + deltas))
307  (define count (length deltas))
308  (define mean (/ sum count))
309  (define imean (exact->inexact mean))
310  (define var (/ (for/sum ([delta (in-list deltas)]) (sqr (- delta imean))) count))
311  (list sum (round mean) count (sqrt var)))
312
313;; sort-order->key : Symbol -> (ProfileEntry -> Real)
314(define (sort-order->key so)
315  (case so
316    [(total) pe->total]
317    [(direct) pe->direct]
318    [(totalmean) pe->totalmean]
319    [(directmean) pe->directmean]))
320
321;; make-exclude : String -> (Id Nat -> Boolean)
322(define ((make-exclude prefix) id ph)
323  (match (identifier-binding id ph)
324    [(list* def-mpi def-sym _)
325     (let loop ([mod (mpi->module-path def-mpi)])
326       (match mod
327         [(? string?) (string-prefix? mod prefix)]
328         [(? symbol?) (loop (symbol->string mod))]
329         [(? path?) (loop (path->string mod))]
330         [(list 'submod mod _ ...) (loop mod)]
331         [(list 'file mod) (loop mod)]
332         [(list 'lib mod) (loop mod)]
333         [_ #f]))]
334    [_ #f]))
335
336;; print-entry : ProfileEntry[Frame] -> Void
337(define (print-entry e)
338  (match-define (list key indirect (list* dtotal dmean dcount dstddev _)) e)
339  (unless (and (zero? indirect) (zero? dtotal))
340    (printf "~a\n" (frame->string key))
341    (printf "  total: ~s, mean: ~s\n"
342            indirect (round (/ indirect dcount)))
343    (printf "  direct: ~s, mean: ~s, count: ~s, stddev: ~a\n"
344            dtotal dmean dcount (~r #:precision 2 dstddev))))
345
346;; frame->string : Frame -> String
347(define (frame->string f)
348  (match-define (fr id phase) f)
349  (id->string id phase))
350
351;; id->string : Identifier Nat -> String
352(define (id->string id phase)
353  (match (identifier-binding id phase)
354    [(list* def-mpi def-sym nom-mpi nom-sym def-phase _)
355     (define at-phase (if (zero? def-phase) "" (format " at phase ~s" def-phase)))
356     (define at-src (mpi->module-path def-mpi))
357     (cond [(eq? def-sym nom-sym)
358            (format "~s (defined in ~s~a)" def-sym at-src at-phase)]
359           [else
360            (format "~s (defined as ~s in ~s~a)" nom-sym def-sym at-src at-phase)])]
361    ['lexical
362     (format "~s (lexical)" (syntax-e id))]
363    [#f
364     (format "~s (top-level)" (syntax-e id))]))
365
366;; ============================================================
367;; External representations
368
369;; mod->external : ModulePath/ModulePathIndex -> String
370(define (mod->external m) (format "~s" (mod->external* m)))
371
372;; mod->external* : ModulePath/ModulePathIndex -> Datum
373(define (mod->external* m)
374  (or (hash-ref mod->external-cache m #f)
375      (let ([ext (mod->external** m)])
376        (hash-set! mod->external-cache m ext)
377        ext)))
378(define mod->external-cache (make-weak-hash))
379(define (mod->external** m) (nice-modpath m))
380
381;; frame->external : Frame -> (list String*3)
382(define (frame->external f)
383  (or (dict-ref frame->external-cache f #f)
384      (let ([ext (frame->external* f)])
385        (dict-set! frame->external-cache f ext)
386        ext)))
387(define frame->external-cache (make-weak-fr-hash))
388(define (frame->external* f)
389  (match f [(fr id phase) (map (lambda (v) (format "~s" v)) (id->external id phase))]))
390
391;; id->external : Identifier Nat ModulePath -> (list Datum*3)
392(define (id->external id phase)
393  (match (identifier-binding id phase)
394    [(list* def-mpi def-sym nom-mpi nom-sym def-phase _)
395     (define src
396       (cond [(here-mpi? def-mpi) (nice-modpath (enclosing-modpath))]
397             [else (nice-modpath def-mpi)]))
398     (list nom-sym src (list 'def def-sym def-phase))]
399    ['lexical
400     (list (syntax-e id) (nice-modpath (enclosing-modpath)) (list 'lex phase))]
401    [#f
402     (list (syntax-e id) 'top '(top))]))
403
404;; ============================================================
405;; DB Schema
406(require db/base db/sqlite3)
407
408(define SCHEMA-VERSION 1)
409
410;; get-profile-db : Path -> DB
411(define (get-profile-db db-file)
412  (define db (sqlite3-connect #:database db-file #:mode 'create))
413  (cond [(table-exists? db "racket_macro_profiler_meta")
414         (define schema-version
415           (query-maybe-value db "select value from racket_macro_profiler_meta where key = ?"
416                              "schema version"))
417         (unless (equal? schema-version SCHEMA-VERSION)
418           (error 'profile "incompatible database file\n  file: ~e" db-file))]
419        [else (call-with-transaction db (lambda () (setup-db db)))])
420  db)
421
422;; setup-db : DB -> Void
423(define (setup-db db)
424  ;; ---- meta ----
425  (query-exec
426   db (~a "create table racket_macro_profiler_meta "
427          "(key text primary key, value any)"))
428  (query-exec db "insert into racket_macro_profiler_meta (key, value) values (?, ?)"
429              "schema version" SCHEMA-VERSION)
430  ;; ---- raw data ----
431  (query-exec
432   db (~a "create table id_module "
433          "(id integer primary key, mod text, unique (mod))"))
434  (query-exec
435   db (~a "create table id_macro "
436          "(id integer primary key, m_sym text, m_src text, m_etc text, "
437          "unique (m_sym, m_src, m_etc))"))
438  (query-exec
439   db (~a "create table mocs "
440          "(expmod integer, ctr integer, start integer, end integer, adj integer, "
441          "primary key (expmod, ctr), "
442          "foreign key (expmod) references id_module (id) on delete cascade)"))
443  (query-exec
444   db (~a "create table mocctx "
445          "(expmod integer, ctr integer, depth integer, macro integer, phase integer, "
446          "primary key (expmod, ctr, depth), "
447          "foreign key (expmod, ctr) references mocs (expmod, ctr) on delete cascade, "
448          "foreign key (macro) references id_macro (id) on delete cascade)"))
449  ;; ---- views ----
450  (query-exec
451   db (~a "create view mocs_direct "
452          "as select expmod, ctr, macro, phase, (end - start + adj) as cost "
453          "from mocs natural inner join mocctx "
454          "where mocctx.depth = 0"))
455  (query-exec
456   db (~a "create view mocs_indirect "
457          "as select distinct expmod, ctr, macro, phase, (end - start + adj) as cost "
458          "from mocs natural inner join mocctx"))
459  (query-exec
460   db (~a "create view cost_direct as "
461          "select macro, phase, "
462          " sum(cost) as dtotal, count(ctr) as dcount, avg(cost) as dmean "
463          "from mocs_direct group by macro, phase"))
464  (query-exec
465   db (~a "create view cost_indirect as "
466          "select macro, phase, sum(cost) as itotal "
467          "from mocs_indirect group by macro, phase"))
468  (query-exec
469   db (~a "create view cost_summary_pre as "
470          "select macro, phase, "
471          " dcount, dtotal, dmean, itotal, (1.0 * itotal / dcount) as imean "
472          "from cost_direct natural inner join cost_indirect"))
473  (query-exec
474   db (~a "create view cost_summary as "
475          "select m_sym, m_src, m_etc, phase, dcount, dtotal, dmean, itotal, imean "
476          "from cost_summary_pre inner join id_macro on (cost_summary_pre.macro = id_macro.id)"))
477  )
478
479(define frame=>key (make-weak-fr-hash))
480(define (frame->key db f)
481  (define (notfound)
482    (match-define (list f-sym f-src f-etc) (frame->external f))
483    (or (query-maybe-value db "select id from id_macro where m_sym = ? and m_src = ? and m_etc = ?"
484                           f-sym f-src f-etc)
485        (let ([next (add1 (query-value db "select coalesce(max(id),0) from id_macro"))])
486          (query-exec db "insert into id_macro (id, m_sym, m_src, m_etc) values (?,?,?,?)"
487                      next f-sym f-src f-etc)
488          next)))
489  (dict-ref! frame=>key f notfound))
490
491(define mod=>key (make-weak-hash))
492(define (mod->key db m)
493  (define (notfound)
494    (define ext (mod->external m))
495    (or (query-maybe-value db "select id from id_module where mod = ?" ext)
496        (let ([next (add1 (query-value db "select coalesce(max(id),0) from id_module"))])
497          (query-exec db "insert into id_module (id, mod) values (?,?)" next ext)
498          next)))
499  (dict-ref! mod=>key m notfound))
500
501;; db-update! : DB ModulePath (Listof MOC) -> ProfInfo
502(define (db-update! db modpath mocs)
503  (define mod-id (mod->key db modpath))
504  (query-exec db "delete from mocs where expmod = ?" mod-id)
505  (query-exec db "delete from mocctx where expmod = ?" mod-id)
506  (for ([m (in-list mocs)] [ctr (in-naturals)])
507    (match-define (moc ctx init final adj) m)
508    (query-exec db "insert into mocs (expmod, ctr, start, end, adj) values (?,?,?,?,?)"
509                mod-id ctr init final adj)
510    (for ([f (in-list ctx)] [depth (in-naturals)])
511      (query-exec db "insert into mocctx (expmod, ctr, depth, macro, phase) values (?,?,?,?,?)"
512                  mod-id ctr depth (frame->key db f) (fr-phase f)))))
513
514;; db-has-mod? : DB ModulePath -> Boolean
515(define (db-has-mod? db rmodpath)
516  (define mod-ext (mod->external rmodpath))
517  (cond [(query-maybe-value db "select id from id_module where mod = ?" mod-ext)
518         => (lambda (mod-id)
519              (not (zero? (query-value db "select count(*) from mocs where expmod = ?" mod-id))))]
520        [else #f]))
521
522;; ============================================================
523
524(module+ main
525  (define mode 'auto)
526  (define the-sort-order 'total)
527  (define the-excludes null)
528  (define print-summary? #t)
529  (define the-db-file #f)
530  (define always-update-db? #t)
531
532  (define (->modpath x)
533    (cond [(string? x)
534           (case mode
535             [(auto)
536              (if (file-exists? x)
537                  `(file ,x)
538                  (read (open-input-string x)))]
539             [(file) `(file ,x)]
540             [(module-path)
541              (read (open-input-string x))])]
542          [else x]))
543
544  (define (process-mod rmodpath db profinfo)
545    (parameterize ((enclosing-modpath rmodpath))
546      (printf "profiling ~s\n" (nice-modpath rmodpath))
547      (define-values (compiled deriv) (get-module-code/trace rmodpath))
548      (define mocs (profile/top deriv))
549      (when profinfo
550        (profinfo-update! profinfo
551                          (term-size (node-z1 deriv))
552                          (term-size (node-z2 deriv))
553                          mocs))
554      (when db
555        (call-with-transaction db
556          (lambda () (db-update! db rmodpath mocs))))))
557
558  (command-line
559   #:program (short-program+command-name)
560   #:once-each
561   [("-f" "--file") "Interpret arguments as file-paths"
562    (set! mode 'file)]
563   [("-m" "--module-path") "Interpret arguments as module-paths"
564    (set! mode 'module-path)]
565   [("-s" "--sort") sort-order
566    "Sort entries by <sort-order> (one of total, totalmean, direct, or directmean)"
567    (let ([so (string->symbol sort-order)])
568      (unless (memq so '(total totalmean direct directmean))
569        (error 'profile "expected one of (total, totalmean, direct, or directmean) for sort order, given: ~a" so))
570      (set! the-sort-order so))]
571   [("-q" "--quiet")
572    "Do not print summary"
573    (set! print-summary? #f)]
574   [("-d" "--database") db-file
575    "Store profile information in sqlite3 db file"
576    (set! the-db-file db-file)]
577   [("-t" "--trust")
578    "Trust existing profile information in the db file"
579    (set! always-update-db? #f)]
580   #:multi
581   [("-x" "--exclude") prefix "Exclude macros defined in modules starting with <prefix> from output"
582    (set! the-excludes (cons (make-exclude prefix) the-excludes))]
583   #:args module-path
584   (let ()
585     (define modpaths (map ->modpath module-path))
586     (define db (and the-db-file (get-profile-db the-db-file)))
587     (define profinfo (and print-summary? (new-profinfo)))
588     ;; ----
589     (for ([modpath (in-list modpaths)])
590       (define rmodpath (resolve-module-path modpath))
591       (cond [(or profinfo always-update-db? (not (db-has-mod? db rmodpath)))
592              (with-handlers ([exn:fail?
593                               (lambda (e)
594                                 (eprintf "ERROR processing ~e\n" rmodpath)
595                                 ((error-display-handler) (exn-message e) e))])
596                (process-mod rmodpath db profinfo))]
597             [else (eprintf "skipping ~s\n" (nice-modpath rmodpath))]))
598     ;; ----
599     (when db
600       (disconnect db))
601     (when profinfo
602       (print-profinfo profinfo #:sort the-sort-order #:excludes the-excludes))))
603  (void))
604