suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

avoid excessive path retention in raco dist output

Browse Source 
This change builds on 5c909cca0d, but it better handles files that
are installed in "lib" or "share" instead of residing in a
package.
This commit is contained in:
Matthew Flatt 2015-11-14 08:31:23 -07:00
parent 8ec17deed1
commit e3d78e44cc
1 changed files with 52 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
racket/collects/compiler/distribute.rkt
View File

@ -513,7 +513,10 @@
exts-dir relative-exts-dir exts-dir relative-exts-dir
relative->binary-relative) relative->binary-relative)
(unless (null? paths) (unless (null? paths)
;; Determine the shared path prefix among paths within a package: ;; Determine the shared path prefix among paths within a package,
;; "collects" directory, or other root. That way, relative path references
;; can work, but we don't keep excessive path information from the
;; build machine.
(let* ([root-table (make-hash)] (let* ([root-table (make-hash)]
[root->path-element (lambda (root) [root->path-element (lambda (root)
(hash-ref root-table (hash-ref root-table
@ -522,42 +525,73 @@
(let ([v (format "r~a" (hash-count root-table))]) (let ([v (format "r~a" (hash-count root-table))])
(hash-set! root-table root v) (hash-set! root-table root v)
v))))] v))))]
[alt-paths (map explode-path
(map normal-case-path
(list* (find-system-path 'addon-dir)
(find-share-dir)
(append (get-lib-search-dirs)
(get-include-search-dirs)))))]
[explode (lambda (src) [explode (lambda (src)
;; Sort the path into a root, and keep the root plus
;; the part of the path relative to that root:
(define-values (pkg subpath) (define-values (pkg subpath)
(path->pkg+subpath src #:cache pkg-path-cache)) (path->pkg+subpath src #:cache pkg-path-cache))
(define main (define main
(and (not pkg) (and (not pkg)
(path->main-collects-relative src))) (path->main-collects-relative src)))
(define other (and (not pkg)
(not (pair? main))
(let ([e (explode-path src)])
(for/or ([d (in-list alt-paths)]
[i (in-naturals)])
(define len (length d))
(and ((length e) . > . len)
(equal? d (take e len))
(cons i len))))))
(reverse (reverse
(let loop ([src (cond (let loop ([src (cond
[pkg subpath] [pkg subpath]
[(pair? main) [(pair? main)
(apply build-path (apply build-path
(map bytes->path-element (cdr main)))] (map bytes->path-element (cdr main)))]
[other (apply build-path
(list-tail (explode-path src) (cdr other)))]
[else src])]) [else src])])
(let-values ([(base name dir?) (split-path src)]) (let-values ([(base name dir?) (split-path src)])
(cond (cond
[(path? base) [(path? base)
(cons name (loop base))] (cons name (loop base))]
[(or pkg
(and (pair? main)
'collects)
(and other (car other)))
=> (lambda (r)
(list name (root->path-element r)))]
[else [else
(list (root->path-element (or pkg (list (root->path-element name))])))))]
(and (pair? main)
'collects)
name)))])))))]
;; In reverse order, so we can pick off the paths ;; In reverse order, so we can pick off the paths
;; in the second pass: ;; in the second pass:
[exploded (reverse (map explode paths))] [exploded (reverse (let ([exploded (map explode paths)])
[max-len (apply max 0 (map length exploded))] ;; For paths that share the same root,
[common-len (let loop ([cnt 0]) ;; drop any common "prefix" after the root.
(cond (define roots-common
[((add1 cnt) . = . max-len) cnt] (for/fold ([ht (hash)]) ([e (in-list exploded)])
[(andmap (let ([i (list-ref (car exploded) cnt)]) (define l (hash-ref ht (car e) #f))
(lambda (e) (hash-set ht (car e)
(equal? (list-ref e cnt) i))) (if (not l)
exploded) (cdr e)
(loop (add1 cnt))] (let loop ([l l] [l2 (cdr e)])
[else cnt]))]) (cond
[(or (null? l) (null? l2)) null]
[(or (null? l) (null? l2)) null]
[(equal? (car l) (car l2))
(cons (car l) (loop (cdr l) (cdr l2)))]
[else null]))))))
;; Drop common parts out, but deefinitely keep the last
;; element:
(for/list ([e (in-list exploded)])
(define l (hash-ref roots-common (car e) null))
(cons (car e) (list-tail (cdr e) (max 0 (sub1 (length l))))))))])
;; Pass 2: change all the paths ;; Pass 2: change all the paths
(copy-and-patch-binaries #t #rx#"rUnTiMe-paths[)]" (copy-and-patch-binaries #t #rx#"rUnTiMe-paths[)]"
@ -569,7 +603,7 @@
(lambda (src) (lambda (src)
(and src (and src
(begin0 (begin0
(apply build-path (list-tail (car exploded) common-len)) (apply build-path (car exploded))
(set! exploded (cdr exploded))))) (set! exploded (cdr exploded)))))
;; transform-entry ;; transform-entry
(lambda (new-path ext) (lambda (new-path ext)