diff --git a/collects/setup/private/preferred-order-gen.rkt b/collects/setup/private/preferred-order-gen.rkt deleted file mode 100644 index ea0fd8fb92..0000000000 --- a/collects/setup/private/preferred-order-gen.rkt +++ /dev/null @@ -1,347 +0,0 @@ -#lang racket/base -(require setup/dirs - setup/main-collects - racket/set - racket/contract - racket/runtime-path - racket/pretty) - -;; hash[(listof bytes) -o> (set/c (listof bytes))] -;; maps from a collection to its dependencies -(define dep-ht (make-hash)) - -(define (main) - (printf "reading dep files\n") - (populate-dep-ht) - ;(write-out-dot-file "before.dot") - (break-cycles) - ;(write-out-dot-file "after.dot") - (printf "saving ~a\n" preferred-order.rkt) - (save-file (tsort dep-ht))) - -(define-runtime-path preferred-order.rkt "preferred-order.rkt") - -(define (save-file l) - (call-with-output-file preferred-order.rkt - (λ (port) - (define per-line 6) - (fprintf port "#lang racket/base\n") - (fprintf port ";; this file was generated by preferred-order-gen.rkt -- do not edit\n") - (display "(define preferred-order\n" port) - (display " '(" port) - (define line-width 0) - (define (out fmt . args) - (define str (apply format fmt args)) - (set! line-width (+ line-width (string-length str))) - (display str port)) - (for ([x (in-list l)] - [i (in-naturals)]) - (unless (zero? i) - (cond - [(line-width . > . 60) - (display "\n " port) - (set! line-width 0)] - [else - (out " ")])) - (out "~s" x)) - (display "))\n" port) - (for ([x (in-list code)]) - (pretty-write x port))) - #:exists 'truncate)) - -(define code - '((define preferred-order-ht (make-hash)) - (for ([c (in-list preferred-order)] - [x (in-naturals)]) - (hash-set! preferred-order-ht c x)) - - (define (collection-bytes-comparison a-bytess b-bytess) - (define a-n (hash-ref preferred-order-ht a-bytess #f)) - (define b-n (hash-ref preferred-order-ht b-bytess #f)) - (cond - [(and a-n b-n) (< a-n b-n)] - ;; these three latter conditions can happen when - ;; there is a collection that has no files (at the - ;; time that the preferred-order list was built) - [(and (not a-n) (not b-n)) - (string<=? (format "~s" a-bytess) (format "~s" b-bytess))] - [a-n #t] - [else #f])) - - (provide collection-bytes-comparison))) - - - -; -; -; -; -; ; -; ;;; -; ;;;; ;;; ;;; ;;;;; -; ;;; ;; ;;;;; ;;;;;;;;; -; ;;; ;;; ;;; ;;; ;;; -; ;;;; ;;; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;; -; ;; ;;; ;;;;; ;;; ;;;; -; ;;;; ;;; ;;; ;;; -; -; -; -; - -;; sort : hash[bytes -o> (listof bytes)] -> (listof bytes) -;; clobbers dep-ht -(define (tsort dep-ht) - (define pending '()) - (define back-ht (make-hash)) - (for ([(node depends-ons) (in-hash dep-ht)]) - (for ([depends-on (in-set depends-ons)]) - (hash-set! back-ht depends-on - (cons node (hash-ref back-ht depends-on '()))))) - (for ([(node depends-ons) (in-hash dep-ht)]) - (when (set-empty? depends-ons) - (set! pending (cons node pending)))) - (define (do-sort pending) (sort pending string<=? #:key (λ (x) (format "~s" x)))) - (set! pending (do-sort pending)) - (let loop ([pending pending]) - (cond - [(null? pending) '()] - [else - (define fst (car pending)) - (define new-ones '()) - (for ([neighbor (in-list (do-sort (hash-ref back-ht fst '())))]) - (when (hash-ref dep-ht neighbor #f) - (define new-set (set-remove (hash-ref dep-ht neighbor) fst)) - (cond - [(set-empty? new-set) - (set! new-ones (cons neighbor new-ones)) - (hash-remove! dep-ht neighbor)] - [else - (hash-set! dep-ht neighbor new-set)]))) - ;; put the newly available collections at the end of the list - ;; in hopes that they don't actually start until the thing that - ;; let them get on the list actually gets finished compiling - (cons fst (loop (append (cdr pending) new-ones)))]))) - -(require rackunit) -(check-equal? (tsort (make-hash '())) '()) -(check-equal? (tsort (make-hash (list (cons #"a" (set))))) '(#"a")) -(check-equal? (tsort (make-hash (list (cons #"a" (set #"b")) - (cons #"b" (set))))) - '(#"b" #"a")) -(check-equal? (tsort (make-hash (list (cons #"a" (set #"b" #"c")) - (cons #"b" (set)) - (cons #"c" (set))))) - '(#"b" #"c" #"a")) -(check-equal? (tsort (make-hash (list (cons #"a" (set #"b" #"c")) - (cons #"b" (set)) - (cons #"c" (set #"b"))))) - '(#"b" #"c" #"a")) -(check-equal? (tsort (make-hash (list (cons #"a" (set #"b" #"c")) - (cons #"b" (set #"c")) - (cons #"c" (set))))) - '(#"c" #"b" #"a")) - - - -; -; -; -; -; ;;; ;;; ;;; -; ;;; ;;; ;;; -; ;;; ;; ;;; ;; ;;;; ;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;; ;;;; -; ;;;;;;; ;;;;; ;; ;;; ;;;;;;; ;;; ;;; ;;;;; ;;; ;;; ;;;;; ;;; ;; ;;; ;;; ;; -; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;;;;; ;;; ;; ;; ;; ;;; ;; ;;; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;;;;;; ;;;;; ;;;;;; ;;; ;; ;; ;;; ;;; ;;;;;;; ;;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;; ;; ;; ;; ;;; ;; ;;; ;;; ;;; -; ;;;;;;; ;;; ;;;;;; ;;; ;;; ;;; ;;; ;;;;; ;;; ;;;;; ;;; ;;;;;; ;; ;;; -; ;;; ;; ;;; ;;;; ;;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;; ;;;; -; ;;;;; -; ;;;; -; -; - -(define (break-cycles) - (printf "breaking cycles: ") (flush-output) - (define cycles-removed - (let loop ([n 0]) - (cond - [(break-a-cycle) - (when (= 9 (modulo n 10)) - (printf ".") (flush-output)) - (loop (+ n 1))] - [else n]))) - (printf " done\n") - (printf "removed ~a edges\n" cycles-removed)) - -;; break-a-cycle : -> boolean -;; returns #t if it found a cycle to break -(define (break-a-cycle) - (define visited (make-hash)) - - (define (break-a-cycle-from n) - (let loop ([n n] - [path '()]) - (cond - [(member n path) - (break-a-link n path) - #t] - [(hash-ref visited n #f) #f] - [else - (define new-path (cons n path)) - (hash-set! visited n #t) - (for/or ([neighbor (in-set (hash-ref dep-ht n (set)))]) - (loop neighbor new-path))]))) - - (define (break-a-link n nodes) - ;; cycle : (cons/c bytes (cons/c bytes (listof bytes))) - (define cycle (reverse (cons n (remove-following n nodes)))) - (define max-size (set-count (hash-ref dep-ht (car cycle)))) - (define max-src-node (car cycle)) - (define max-dest-node (cadr cycle)) - (for ([n-src (in-list (cdr cycle))] - [n-dest (in-list (cddr cycle))]) - (define n-size (set-count (hash-ref dep-ht n-src))) - (when (> n-size max-size) - (set! max-src-node n-src) - (set! max-dest-node n-dest) - (set! max-size n-size))) - (define set-before (hash-ref dep-ht max-src-node)) - (unless (set-member? set-before max-dest-node) - (error 'break-a-link "there is no link there!")) - (hash-set! dep-ht max-src-node (set-remove set-before max-dest-node))) - - - (define (remove-following n nodes) - (cond - [(equal? n (car nodes)) (list (car nodes))] - [else (cons (car nodes) (remove-following n (cdr nodes)))])) - - (for/or ([(k v) (in-hash dep-ht)]) - (break-a-cycle-from k))) - - -; -; -; -; -; ;;; ;;; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;; -; ;;; ;; ;;; ;;; ;;; ;;; ;; ;;; ;; ;;; ;;; ;;;;;;; ;;; ;; ;;; ;; -; ;;;;;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;;;;;; ;;;;;;;;;;;; ;;;;;;; ;;;;;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;; ;;; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; -; ;;;;;;; ;;;;;;; ;;; ;;; ;;;;;;; ;;;;;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; -; ;;; ;; ;; ;;; ;;; ;;; ;; ;;; ;; ;;; ;;; ;;;;;; ;;; ;; ;;; ;;; -; ;;; ;;; -; ;;;;;; ;;; -; -; - - -(define (populate-dep-ht) - (process-dir/file (find-collects-dir))) - -(define (process-dir/file d/f) - (cond - [(directory-exists? d/f) - (for ([s-d/f (in-list (directory-list d/f))]) - (process-dir/file (build-path d/f s-d/f)))] - [(file-exists? d/f) - (when (regexp-match? #rx#"[.]dep$" (path->bytes d/f)) - (process-dep-file d/f))])) - -(define (process-dep-file fn) - (define coll-rel (path->main-collects-relative fn)) - (when (path? coll-rel) (error 'process-dep-file "how did we get here? ~s" fn)) - (define this-coll (collect->key coll-rel)) ;; drop 'compiled' dir - (define dep-content (call-with-input-file fn read)) - (define dependencies (cddr dep-content)) - (for ([dep (in-list dependencies)]) - (unless (eq? (car dep) 'ext) - (define coll (collect->key dep)) - (unless (equal? coll this-coll) - (add-dep this-coll coll))))) - -(define (add-dep from-coll to-coll) - (hash-set! dep-ht from-coll (set-add (hash-ref dep-ht from-coll (set)) to-coll))) - -;; takes the results of path->main-collects-relative, but expects '(collects ...) -;; form and returns the name of a node in the graph -(define (collect->key coll) - (cadr coll)) - -; -; -; -; -; ;;; ; -; ;;; ;;; -; ;; ;;; ;;; ;;;; -; ;;;;;;; ;;;;; ;;;; -; ;;; ;;; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;; -; ;;;;;;; ;;;;; ;;;; -; ;; ;;; ;;; ;;; -; -; -; -; - - -(define (write-out-dot-file fn) - ;; this graph seems to draw better with 'neato' than 'dot'. - ;; Here's the command-line that I was using: - ;; neato -Goverlap=scale -Tps fn.dot > fn.ps - ;; (but it isn't particularly informative, even with neato) - (define (cleanup-name name) - (regexp-replace* - #rx#"2" - (regexp-replace* - #rx#"-" - (regexp-replace* - #rx#" " - (regexp-replace* - #rx#"[(]" - (regexp-replace* - #rx#"[)]" - (regexp-replace* - #rx#"[#]" - (regexp-replace* - #rx#"[\"]" - (regexp-replace* - #rx#"[3]" - (regexp-replace* - #rx#"[%]" - (regexp-replace* - #rx#"[+]" - (format "~s" name) - #"_pls_") - #"_per_") - #"_thr_") - #"_q_") - #"_hsh_") - #"_cp_") - #"_op_") - #"_spc_") - #"_hyp_") - #"_two_")) - - (call-with-output-file fn - (λ (port) - (fprintf port "digraph {\n") - (for ([(src dests) (in-hash dep-ht)]) - (fprintf port " ~a [label=\"~a\"]\n" - (cleanup-name src) - (regexp-replace* #rx"\"" (format "~s" src) "\\\\\""))) - (for ([(src dests) (in-hash dep-ht)]) - (for ([dest (in-set dests)]) - (fprintf port " ~a -> ~a [color=gray]\n" (cleanup-name src) (cleanup-name dest)))) - (fprintf port "}\n")) - #:exists 'truncate)) - -(main) diff --git a/collects/setup/private/preferred-order.rkt b/collects/setup/private/preferred-order.rkt deleted file mode 100644 index ef0cfee10f..0000000000 --- a/collects/setup/private/preferred-order.rkt +++ /dev/null @@ -1,34 +0,0 @@ -#lang racket/base -;; this file was generated by preferred-order-gen.rkt -- do not edit -(define preferred-order - '(#"racket" #"scheme" #"planet" #"syntax" #"scribble" #"s-exp" #"reader" - #"mzscheme" #"errortrace" #"at-exp" #"parser-tools" #"openssl" - #"framework" #"unstable" #"syntax-color" #"scribblings" #"mzlib" - #"dynext" #"setup" #"compiler" #"trace" #"scriblib" #"raco" #"r5rs" - #"profile" #"preprocessor" #"ffi" #"datalog" #"config" #"combinator-parser" - #"browser" #"mrlib" #"typed-racket" #"tex2page" #"readline" #"mysterx" - #"racklog" #"icons" #"hierlist" #"deinprogramm" #"mzcom" #"lang" - #"test-engine" #"typed" #"typed-scheme" #"images" #"stepper" #"drracket" - #"repo-time-stamp" #"drscheme" #"version" #"rackunit" #"string-constants" - #"slatex" #"schemeunit" #"r6rs" #"launcher" #"file" #"data" #"xml" - #"lazy" #"eopl" #"rnrs" #"mred" #"make" #"macro-debugger" #"wxme" - #"html" #"srfi" #"texpict" #"test-box-recovery" #"sgl" #"graphics" - #"embedded-gui" #"algol60" #"xrepl" #"honu" #"web-server" #"slideshow" - #"frtime" #"plai" #"net" #"htdp" #"db" #"redex" #"gui-debugger" - #"swindle" #"sirmail" #"help" #"handin-client" #"handin-server" - #"2htdp" #"plot" #"teachpack" #"games" #"tests" #"picturing-programs" - #"meta")) -(define preferred-order-ht (make-hash)) -(for - ((c (in-list preferred-order)) (x (in-naturals))) - (hash-set! preferred-order-ht c x)) -(define (collection-bytes-comparison a-bytess b-bytess) - (define a-n (hash-ref preferred-order-ht a-bytess #f)) - (define b-n (hash-ref preferred-order-ht b-bytess #f)) - (cond - ((and a-n b-n) (< a-n b-n)) - ((and (not a-n) (not b-n)) - (string<=? (format "~s" a-bytess) (format "~s" b-bytess))) - (a-n #t) - (else #f))) -(provide collection-bytes-comparison) diff --git a/collects/setup/setup-unit.rkt b/collects/setup/setup-unit.rkt index eb62629fdd..c576ff073a 100644 --- a/collects/setup/setup-unit.rkt +++ b/collects/setup/setup-unit.rkt @@ -30,8 +30,7 @@ "private/omitted-paths.rkt" "parallel-build.rkt" "collects.rkt" - "link.rkt" - "private/preferred-order.rkt") + "link.rkt") (define-namespace-anchor anchor) ;; read info files using whatever namespace, .zo-use, and compilation @@ -450,9 +449,8 @@ (define (sort-collections ccs) (sort ccs stringbytes (first (cc-collection (first x))))))) + (define (sort-collections-tree ccs) + (sort ccs string . 1))) - (managed-compile-zo (collection-file-path "parallel-build-worker.rkt" "setup")) - (with-specified-mode - (lambda () - (define cct (sort-collections-for-compilation - (collection-tree-map top-level-plt-collects))) - (iterate-cct (lambda (cc) - (let ([dir (cc-path cc)] - [info (cc-info cc)]) - (clean-cc dir info))) cct) - (parallel-compile (parallel-workers) setup-fprintf handle-error cct) + (compile-cc (collection->cc (list (string->path "racket"))) 0) + (managed-compile-zo (collection-file-path "parallel-build-worker.rkt" "setup")) + (with-specified-mode + (lambda () + (let ([cct (move-to 'beginning (list "compiler" "raco" "racket" "images") + (move-to 'end (list "drracket" "drscheme") + (sort-collections-tree + (collection-tree-map top-level-plt-collects))))]) + (iterate-cct (lambda (cc) + (let ([dir (cc-path cc)] + [info (cc-info cc)]) + (clean-cc dir info))) cct) + (parallel-compile (parallel-workers) setup-fprintf handle-error cct)) (for/fold ([gcs 0]) ([cc planet-dirs-to-compile]) (compile-cc cc gcs))))] [else