/usr/share/racket/pkgs/contract-profile/utils.rkt is in racket-common 6.7-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 | #lang racket/base
(require racket/port racket/contract racket/list setup/collects)
(provide (except-out (all-defined-out) shorten-paths))
(struct contract-profile
(total-time
;; (pairof blame? profile-sample)
;; samples taken while a contract was running
live-contract-samples
;; (listof blame?)
;; all the blames that were observed during sampling
all-blames
;; profile?
;; regular time profile
regular-profile))
(define (samples-time samples)
(for/sum ([s (in-list samples)])
(cadr s)))
;; for debugging
(define (format-blame b)
(format (string-append "#<blame positive=~a\n"
" negative=~a\n"
" contract=~a\n"
" value=~a\n"
" source=~a>\n")
(blame-positive b) (blame-negative b)
(blame-contract b) (blame-value b) (blame-source b)))
;; (listof (U path-string? submodule-path #f)) -> same
(define (shorten-paths ps*)
;; zeroth pass, remove non-paths
(define ps
(for/list ([p (in-list ps*)]
#:when (or (path-string? p)
(and (list? p) ; submodule
(not (empty? p))
(path-string? (first p)))))
p))
;; zeroth.5 pass, chop off submodule parts, to put back later
(define submodules ; (hashof path (U submodule-part #f))
(for/hash ([p ps])
(values p (and (list? p) (rest p)))))
;; first pass, convert to collect relative paths if possible
(define w/o-submodules
(for/hash ([p ps])
(values p (path->module-path (if (list? p) (first p) p)))))
;; second pass, make non-collect paths relative to their common ancestor
(define-values (collect-paths non-collect-paths)
(for/fold ([collect-paths (hash)]
[non-collect-paths (hash)])
([(k v) (in-hash w/o-submodules)])
(if (list? v) ; collect path?
(values (hash-set collect-paths k v)
non-collect-paths)
(values collect-paths
(values (hash-set non-collect-paths k v))))))
(define relative-paths
(cond
[(hash-empty? non-collect-paths) ; degenerate case
(hash)]
[else
;; not using hash-keys and hash-values. need the orders to match
(define as-list (hash->list non-collect-paths))
(define origs (map car as-list))
(define vs (map cdr as-list))
;; this transformation preserves order of paths
(define relative
(let loop ([paths (map explode-path vs)])
(define head-base (first (first paths)))
(if (and (for/and ([p (rest paths)]) (equal? (first p) head-base))
(not (for/or ([p paths]) (empty? (rest p)))))
;; all start with the same directory, drop it
;; (and we're not dropping filenames)
(loop (map rest paths))
;; not all the same, we're done
(for/list ([p paths]) (apply build-path p)))))
(for/hash ([o (in-list origs)]
[v (in-list relative)])
(values o v))]))
;; final pass, reassemble submodule parts
;; start with collect paths
(define init-table
(for/hash ([(k v) (in-hash collect-paths)])
(define submodule-part (hash-ref submodules k #f))
(values k
(if submodule-part (cons v submodule-part) v))))
;; then add non-collect paths
(for/fold ([table init-table])
([(k v) (in-hash relative-paths)])
(define submodule-part (hash-ref submodules k #f))
(hash-set table
k
(if submodule-part (cons v submodule-part) v))))
;; (sequenceof A) (A -> (U path-string? submodule-path #f)) -> (A -> (U ...))
(define (make-shortener ps* [extract-path values])
;; special-case things shorten-paths can't deal with
;; these should just map to themselves
(define-values (ps bad)
(partition (lambda (p)
(or (path-string? p)
(and (list? p) ; submodule path
(not (empty? p))
(path-string? (first p)))))
;; can be any kind of sequence, turn into a list
(for/list ([p ps*]) p)))
(define extracted (map extract-path ps))
(define shortened (shorten-paths extracted))
(define init-table
(for/hash ([p ps]
[e extracted])
(values p (hash-ref shortened e))))
;; add bad "paths", mapping to themselves
(define table
(for/fold ([table init-table])
([b (in-list bad)])
(hash-set table b b)))
(lambda (p)
(or (hash-ref table p #f)
(extract-path p))))
(define (make-srcloc-shortener srcs [extract-srcloc values])
(define extracted
(for/list ([s srcs])
(srcloc-source (extract-srcloc s))))
(define shortened (shorten-paths extracted))
(define table
(for/hash ([p srcs]
[e extracted])
(values p (hash-ref shortened e (lambda () p)))))
(lambda (arg)
(define p (if (and (blame? arg) (blame-swapped? arg))
(blame-swap arg)
arg))
(define target (hash-ref table p #f))
(if target
(struct-copy srcloc
(extract-srcloc p)
[source target])
(extract-srcloc p))))
|