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

Each file gets its own tmp dir

Browse Source
This commit is contained in:
Jay McCarthy 2012-05-17 10:28:56 -06:00
parent e12e559878
commit aa3b849382
1 changed files with 178 additions and 172 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

350
collects/meta/drdr/plt-build.rkt
View File

@ -16,8 +16,8 @@
(define-syntax-rule (with-env ([env-expr val-expr] ...) expr ...) (define-syntax-rule (with-env ([env-expr val-expr] ...) expr ...)
(parameterize ([current-env (parameterize ([current-env
(for/fold ([env (current-env)]) (for/fold ([env (current-env)])
([k (in-list (list env-expr ...))] ([k (in-list (list env-expr ...))]
[v (in-list (list val-expr ...))]) [v (in-list (list val-expr ...))])
(hash-set env k v))]) (hash-set env k v))])
expr ...)) expr ...))
@ -39,11 +39,11 @@
(notify! "Removing checkout directory: ~a" co-dir) (notify! "Removing checkout directory: ~a" co-dir)
(safely-delete-directory co-dir) (safely-delete-directory co-dir)
(local [(define repo (plt-repository)) (local [(define repo (plt-repository))
(define to-dir (define to-dir
(path->string co-dir))] (path->string co-dir))]
(notify! "Checking out ~a@~a into ~a" (notify! "Checking out ~a@~a into ~a"
repo rev to-dir) repo rev to-dir)
(scm-export-repo rev repo to-dir)))) (scm-export-repo rev repo to-dir))))
;; Make the build directory ;; Make the build directory
(make-directory* build-dir) (make-directory* build-dir)
;; Run Configure, Make, Make Install ;; Run Configure, Make, Make Install
@ -58,22 +58,22 @@
#:timeout (current-make-timeout-seconds) #:timeout (current-make-timeout-seconds)
#:env (current-env) #:env (current-env)
(build-path log-dir "src" "build" "make") (build-path log-dir "src" "build" "make")
(make-path) (make-path)
(list "-j" (number->string (number-of-cpus)))) (list "-j" (number->string (number-of-cpus))))
(with-env (with-env
(["PLT_SETUP_OPTIONS" (format "-j ~a" (number-of-cpus))]) (["PLT_SETUP_OPTIONS" (format "-j ~a" (number-of-cpus))])
(run/collect/wait/log (run/collect/wait/log
#:timeout (current-make-install-timeout-seconds) #:timeout (current-make-install-timeout-seconds)
#:env (current-env) #:env (current-env)
(build-path log-dir "src" "build" "make-install") (build-path log-dir "src" "build" "make-install")
(make-path) (make-path)
(list "-j" (number->string (number-of-cpus)) "install")))) (list "-j" (number->string (number-of-cpus)) "install"))))
(run/collect/wait/log (run/collect/wait/log
#:timeout (current-make-install-timeout-seconds) #:timeout (current-make-install-timeout-seconds)
#:env (current-env) #:env (current-env)
(build-path log-dir "src" "build" "archive") (build-path log-dir "src" "build" "archive")
(tar-path) (tar-path)
(list "-czvf" (list "-czvf"
(path->string (revision-trunk.tgz rev)) (path->string (revision-trunk.tgz rev))
"-C" (path->string rev-dir) "-C" (path->string rev-dir)
"trunk"))) "trunk")))
@ -81,96 +81,101 @@
(define (call-with-temporary-directory thunk) (define (call-with-temporary-directory thunk)
(define tempdir (symbol->string (gensym 'tmpdir))) (define tempdir (symbol->string (gensym 'tmpdir)))
(dynamic-wind (dynamic-wind
(lambda () (lambda ()
(make-directory* tempdir)) (make-directory* tempdir))
(lambda () (lambda ()
(parameterize ([current-directory tempdir]) (parameterize ([current-directory tempdir])
(thunk))) (thunk)))
(lambda () (lambda ()
(delete-directory/files tempdir)))) (delete-directory/files tempdir))))
(define-syntax-rule (with-temporary-directory e) (define-syntax-rule (with-temporary-directory e)
(call-with-temporary-directory (lambda () e))) (call-with-temporary-directory (lambda () e)))
(define (call-with-temporary-planet-directory thunk) (define-syntax-rule
(define tempdir (define-with-temporary-planet-directory with-temporary-planet-directory env-str)
(build-path (current-directory) (begin
(symbol->string (gensym 'planetdir)))) (define (call-with-temporary-planet-directory thunk)
(dynamic-wind (define tempdir
(lambda () (build-path (current-directory)
(make-directory* tempdir)) (symbol->string (gensym 'planetdir))))
(lambda () (dynamic-wind
(with-env (["PLTPLANETDIR" (path->string tempdir)]) (lambda ()
(thunk))) (make-directory* tempdir))
(lambda () (lambda ()
(delete-directory/files tempdir)))) (with-env ([env-str (path->string tempdir)])
(define-syntax-rule (with-temporary-planet-directory e) (thunk)))
(call-with-temporary-planet-directory (lambda () e))) (lambda ()
(delete-directory/files tempdir))))
(define-syntax-rule (with-temporary-planet-directory e)
(call-with-temporary-planet-directory (lambda () e)))))
(define-with-temporary-planet-directory with-temporary-planet-directory "PLTPLANETDIR")
(define-with-temporary-planet-directory with-temporary-tmp-directory "TMPDIR")
(define (call-with-temporary-home-directory thunk) (define (call-with-temporary-home-directory thunk)
(define new-dir (define new-dir
(make-temporary-file (make-temporary-file
"home~a" "home~a"
'directory 'directory
(current-temporary-directory))) (current-temporary-directory)))
(dynamic-wind (dynamic-wind
(lambda () (lambda ()
(with-handlers ([exn:fail? void]) (with-handlers ([exn:fail? void])
(copy-directory/files (copy-directory/files
(hash-ref (current-env) "HOME") (hash-ref (current-env) "HOME")
new-dir))) new-dir)))
(lambda () (lambda ()
(with-env (["HOME" (path->string new-dir)]) (with-env (["HOME" (path->string new-dir)])
(thunk))) (thunk)))
(lambda () (lambda ()
(delete-directory/files new-dir)))) (delete-directory/files new-dir))))
(define-syntax-rule (with-temporary-home-directory e) (define-syntax-rule (with-temporary-home-directory e)
(call-with-temporary-home-directory (lambda () e))) (call-with-temporary-home-directory (lambda () e)))
(define (with-running-program command args thunk) (define (with-running-program command args thunk)
(if command (if command
(let () (let ()
(define-values (new-command new-args) (define-values (new-command new-args)
(command+args+env->command+args (command+args+env->command+args
#:env (current-env) #:env (current-env)
command args)) command args))
(define-values (define-values
(the-process _stdout stdin _stderr) (the-process _stdout stdin _stderr)
(parameterize ([subprocess-group-enabled #t]) (parameterize ([subprocess-group-enabled #t])
(apply subprocess (apply subprocess
(current-error-port) (current-error-port)
#f #f
(current-error-port) (current-error-port)
new-command new-args))) new-command new-args)))
; Die if this program does ;; Die if this program does
(define parent (define parent
(current-thread)) (current-thread))
(define waiter (define waiter
(thread (thread
(lambda () (lambda ()
(subprocess-wait the-process) (subprocess-wait the-process)
(printf "Killing parent because wrapper is dead...\n") (printf "Killing parent because wrapper is dead...\n")
(kill-thread parent)))) (kill-thread parent))))
; Run without stdin ;; Run without stdin
(close-output-port stdin) (close-output-port stdin)
(dynamic-wind (dynamic-wind
void void
; Run the thunk ;; Run the thunk
thunk thunk
(λ () (λ ()
; Close the output ports ;; Close the output ports
#;(close-input-port stdout) #;(close-input-port stdout)
#;(close-input-port stderr) #;(close-input-port stderr)
; Kill the guard ;; Kill the guard
(kill-thread waiter) (kill-thread waiter)
; Kill the process ;; Kill the process
(subprocess-kill the-process #f) (subprocess-kill the-process #f)
(sleep) (sleep)
(subprocess-kill the-process #t)))) (subprocess-kill the-process #t))))
(thunk))) (thunk)))
(define-runtime-path package-list "pkgs") (define-runtime-path package-list "pkgs")
(define (planet-packages) (define (planet-packages)
@ -188,14 +193,14 @@
(path->string (build-path trunk-dir "bin" "racket"))) (path->string (build-path trunk-dir "bin" "racket")))
(define raco-path (define raco-path
(path->string (build-path trunk-dir "bin" "raco"))) (path->string (build-path trunk-dir "bin" "raco")))
; XXX Remove ;; XXX Remove
(define mzc-path (define mzc-path
(path->string (build-path trunk-dir "bin" "mzc"))) (path->string (build-path trunk-dir "bin" "mzc")))
(define gracket-path (define gracket-path
(path->string (build-path trunk-dir "bin" "gracket"))) (path->string (build-path trunk-dir "bin" "gracket")))
(define collects-pth (define collects-pth
(build-path trunk-dir "collects")) (build-path trunk-dir "collects"))
; XXX Use a single GUI thread so that other non-GUI apps can run in parallel ;; XXX Use a single GUI thread so that other non-GUI apps can run in parallel
(define gui-lock (make-semaphore 1)) (define gui-lock (make-semaphore 1))
(define test-workers (make-job-queue (number-of-cpus))) (define test-workers (make-job-queue (number-of-cpus)))
(define (test-directory dir-pth upper-sema) (define (test-directory dir-pth upper-sema)
@ -211,8 +216,8 @@
(sort files/unsorted < (sort files/unsorted <
#:key (λ (p) #:key (λ (p)
(if (bytes=? #"tests" (path->bytes p)) (if (bytes=? #"tests" (path->bytes p))
0 0
1)) 1))
#:cache-keys? #t)) #:cache-keys? #t))
(for ([sub-pth (in-list files)]) (for ([sub-pth (in-list files)])
(define pth (build-path dir-pth sub-pth)) (define pth (build-path dir-pth sub-pth))
@ -226,7 +231,7 @@
[(file-exists? log-pth) [(file-exists? log-pth)
(semaphore-post dir-sema)] (semaphore-post dir-sema)]
[else [else
(define pth-timeout (define pth-timeout
(or (path-timeout pth) (or (path-timeout pth)
(current-subprocess-timeout-seconds))) (current-subprocess-timeout-seconds)))
(define pth-cmd/general (define pth-cmd/general
@ -236,7 +241,7 @@
[#f [#f
#f] #f]
[(list-rest (or 'mzscheme 'racket) rst) [(list-rest (or 'mzscheme 'racket) rst)
(lambda (k) (lambda (k)
(k (list* racket-path rst)))] (k (list* racket-path rst)))]
[(list-rest 'mzc rst) [(list-rest 'mzc rst)
(lambda (k) (k (list* mzc-path rst)))] (lambda (k) (k (list* mzc-path rst)))]
@ -246,47 +251,48 @@
'gracket 'gracket-text) 'gracket 'gracket-text)
rst) rst)
(if (on-unix?) (if (on-unix?)
(lambda (k) (lambda (k)
(call-with-semaphore (call-with-semaphore
gui-lock gui-lock
(λ () (λ ()
(k (k
(list* gracket-path (list* gracket-path
"-display" "-display"
(format (format
":~a" ":~a"
(cpu->child (cpu->child
(current-worker))) (current-worker)))
rst))))) rst)))))
#f)] #f)]
[_ [_
#f])) #f]))
(cond (cond
[pth-cmd [pth-cmd
(submit-job! (submit-job!
test-workers test-workers
(lambda () (lambda ()
(dynamic-wind (dynamic-wind
void void
(λ () (λ ()
(pth-cmd (pth-cmd
(λ (l) (λ (l)
(with-env (with-env
(["DISPLAY" (["DISPLAY"
(format ":~a" (format ":~a"
(cpu->child (cpu->child
(current-worker)))]) (current-worker)))])
(with-temporary-planet-directory (with-temporary-tmp-directory
(with-temporary-home-directory (with-temporary-planet-directory
(with-temporary-directory (with-temporary-home-directory
(run/collect/wait/log (with-temporary-directory
log-pth (run/collect/wait/log
#:timeout pth-timeout log-pth
#:env (current-env) #:timeout pth-timeout
(first l) #:env (current-env)
(rest l))))))))) (first l)
(λ () (rest l))))))))))
(semaphore-post dir-sema)))))] (λ ()
(semaphore-post dir-sema)))))]
[else [else
(semaphore-post dir-sema)])])])) (semaphore-post dir-sema)])])]))
(thread (thread
@ -296,28 +302,28 @@
(notify! "Done with dir: ~a" dir-pth) (notify! "Done with dir: ~a" dir-pth)
(write-cache! dir-log (current-seconds)) (write-cache! dir-log (current-seconds))
(semaphore-post upper-sema)))])) (semaphore-post upper-sema)))]))
; Some setup ;; Some setup
(for ([pp (in-list (planet-packages))]) (for ([pp (in-list (planet-packages))])
(match pp (match pp
[`(,auth ,pkg ,majn ,minn ,ver) [`(,auth ,pkg ,majn ,minn ,ver)
(define maj (number->string majn)) (define maj (number->string majn))
(define min (number->string minn)) (define min (number->string minn))
(run/collect/wait/log (run/collect/wait/log
; XXX Give it its own timeout ;; XXX Give it its own timeout
#:timeout (current-make-install-timeout-seconds) #:timeout (current-make-install-timeout-seconds)
#:env (current-env) #:env (current-env)
(build-path log-dir "planet" auth pkg maj min) (build-path log-dir "planet" auth pkg maj min)
raco-path raco-path
(list "planet" "install" auth pkg maj min))])) (list "planet" "install" auth pkg maj min))]))
(run/collect/wait/log (run/collect/wait/log
#:timeout (current-subprocess-timeout-seconds) #:timeout (current-subprocess-timeout-seconds)
#:env (current-env) #:env (current-env)
(build-path log-dir "src" "build" "set-browser.rkt") (build-path log-dir "src" "build" "set-browser.rkt")
racket-path racket-path
(list "-t" (list "-t"
(path->string* (path->string*
(build-path (drdr-directory) "set-browser.rkt")))) (build-path (drdr-directory) "set-browser.rkt"))))
; And go ;; And go
(define top-sema (make-semaphore 0)) (define top-sema (make-semaphore 0))
(notify! "Starting testing") (notify! "Starting testing")
(when (directory-exists? collects-pth) (when (directory-exists? collects-pth)
@ -329,9 +335,9 @@
(define (recur-many i r f) (define (recur-many i r f)
(if (zero? i) (if (zero? i)
(f) (f)
(r (sub1 i) (lambda () (r (sub1 i) (lambda ()
(recur-many (sub1 i) r f))))) (recur-many (sub1 i) r f)))))
(define XSERVER-OFFSET 20) (define XSERVER-OFFSET 20)
(define ROOTX XSERVER-OFFSET) (define ROOTX XSERVER-OFFSET)
@ -342,7 +348,7 @@
(define (remove-X-locks tmp-dir i) (define (remove-X-locks tmp-dir i)
(for ([dir (in-list (list "/tmp" tmp-dir))]) (for ([dir (in-list (list "/tmp" tmp-dir))])
(safely-delete-directory (safely-delete-directory
(build-path dir (format ".X~a-lock" i))) (build-path dir (format ".X~a-lock" i)))
(safely-delete-directory (safely-delete-directory
(build-path dir ".X11-unix" (format ".X~a-lock" i))) (build-path dir ".X11-unix" (format ".X~a-lock" i)))
@ -367,7 +373,7 @@
(make-directory* planet-dir) (make-directory* planet-dir)
(make-directory* home-dir) (make-directory* home-dir)
(make-directory* tmp-dir) (make-directory* tmp-dir)
; We are running inside of a test directory so that random files are stored there ;; We are running inside of a test directory so that random files are stored there
(parameterize ([current-directory test-dir] (parameterize ([current-directory test-dir]
[current-temporary-directory tmp-dir] [current-temporary-directory tmp-dir]
[current-rev rev]) [current-rev rev])
@ -375,41 +381,41 @@
["GIT_DIR" (path->string (plt-repository))] ["GIT_DIR" (path->string (plt-repository))]
["TMPDIR" (path->string tmp-dir)] ["TMPDIR" (path->string tmp-dir)]
["PLTDRDR" "yes"] ["PLTDRDR" "yes"]
["PATH" ["PATH"
(format "~a:~a" (format "~a:~a"
(path->string (path->string
(build-path trunk-dir "bin")) (build-path trunk-dir "bin"))
(getenv "PATH"))] (getenv "PATH"))]
["PLTPLANETDIR" (path->string planet-dir)] ["PLTPLANETDIR" (path->string planet-dir)]
["HOME" (path->string home-dir)]) ["HOME" (path->string home-dir)])
(unless (read-cache* (revision-commit-msg rev)) (unless (read-cache* (revision-commit-msg rev))
(write-cache! (revision-commit-msg rev) (write-cache! (revision-commit-msg rev)
(get-scm-commit-msg rev (plt-repository)))) (get-scm-commit-msg rev (plt-repository))))
(when (build?) (when (build?)
(build-revision rev)) (build-revision rev))
(define (start-x-server i inner) (define (start-x-server i inner)
(notify! "Starting X server #~a" i) (notify! "Starting X server #~a" i)
(remove-X-locks tmp-dir i) (remove-X-locks tmp-dir i)
(with-running-program (with-running-program
"/usr/bin/Xorg" (list (format ":~a" i)) "/usr/bin/Xorg" (list (format ":~a" i))
(lambda () (lambda ()
(sleep 2) (sleep 2)
(notify! "Starting fluxbox #~a" i) (notify! "Starting fluxbox #~a" i)
(with-running-program (with-running-program
(fluxbox-path) (fluxbox-path)
(list "-display" (list "-display"
(format ":~a" i) (format ":~a" i)
"-rc" "/home/pltdrdr/.fluxbox/init") "-rc" "/home/pltdrdr/.fluxbox/init")
inner)))) inner))))
(start-x-server (start-x-server
ROOTX ROOTX
(lambda () (lambda ()
(sleep 2) (sleep 2)
(notify! "Starting test of rev ~a" rev) (notify! "Starting test of rev ~a" rev)
(test-revision rev))))) (test-revision rev)))))
; Remove the test directory ;; Remove the test directory
(safely-delete-directory test-dir)))) (safely-delete-directory test-dir))))
(provide/contract (provide/contract