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

Merge branch 'master' of git.racket-lang.org:plt

Browse Source
This commit is contained in:
Matthew Flatt 2010-04-20 15:47:14 -06:00
commit 88820fc4a4
5 changed files with 65 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
collects/meta/drdr/plt-build.ss
View File

@ -197,9 +197,7 @@
(lambda ()
(define l (pth-cmd))
(with-env (["DISPLAY" (format ":~a" (+ XSERVER-OFFSET (current-worker)))]
["HOME" (home-dir (current-worker))])
; XXX Maybe this should destroy the old home and copy in a new one
; Otherwise it is a source of randomness
["HOME" (make-fresh-home-dir)])
(with-temporary-directory
(run/collect/wait/log log-pth
#:timeout pth-timeout
@ -234,14 +232,6 @@
(build-path log-dir "src" "build" "set-browser.ss")
mzscheme-path
(list "-t" (path->string* (build-path (drdr-directory) "set-browser.ss"))))
; Make home directories
(cache/file/timestamp
(build-path rev-dir "homedir-dup")
(lambda ()
(notify! "Copying home directory for each worker")
(for ([i (in-range (number-of-cpus))])
(with-handlers ([exn:fail? void])
(copy-directory/files (hash-ref (current-env) "HOME") (home-dir i))))))
; And go
(notify! "Starting testing")
(test-directory collects-pth top-sema)
@ -250,10 +240,11 @@
(notify! "Stopping testing")
(stop-job-queue! test-workers))
(define (home-dir i)
(format "~a~a"
(hash-ref (current-env) "HOME")
i))
(define (make-fresh-home-dir)
(define new-dir (make-temporary-file "home~a" 'directory))
(with-handlers ([exn:fail? void])
(copy-directory/files (hash-ref (current-env) "HOME") new-dir))
(path->string new-dir))
(define (recur-many i r f)
(if (zero? i)

5
collects/meta/drdr/render.ss
View File

@ -557,7 +557,8 @@
(define name (path->string rev-pth))
(define url (format "~a/" name))
(define rev (string->number name))
(define log (read-cache (revision-commit-msg rev)))
(define log-pth (revision-commit-msg rev))
(define log (read-cache log-pth))
(define committer (svn-rev-log-author log))
(define commit-msg (string-first-line (svn-rev-log-msg log)))
(define title
@ -566,7 +567,7 @@
commit-msg))
(define (no-rendering-row)
(define mtime
(file-or-directory-modify-seconds (build-path builds-pth rev-pth)))
(file-or-directory-modify-seconds log-pth))
`(tr ([class "dir"]
[title ,title])

45
collects/meta/drdr/rewriting.ss
View File

@ -1,30 +1,31 @@
#lang scheme
(require "dirstruct.ss"
"status.ss")
(require "status.ss")
(define (rewrite-status s)
(if (current-rev)
(local [(define from (number->string (current-rev)))]
(match s
[(struct exit (start end command-line output-log code))
(make-exit start end (rewrite-strings from command-line) (rewrite-events from output-log) code)]
[(struct timeout (start end command-line output-log))
(make-timeout start end (rewrite-strings from command-line) (rewrite-events from output-log))]))
s))
(define (rewrite-status #:rewrite rewrite-string s)
(match s
[(struct exit (start end command-line output-log code))
(make-exit start end
(rewrite-strings #:rewrite rewrite-string command-line)
(rewrite-events #:rewrite rewrite-string output-log)
code)]
[(struct timeout (start end command-line output-log))
(make-timeout start end
(rewrite-strings #:rewrite rewrite-string command-line)
(rewrite-events #:rewrite rewrite-string output-log))]))
(define (rewrite-strings from los)
(map (curry rewrite-string from) los))
(define (rewrite-events from loe)
(map (rewrite-event from) loe))
(define (rewrite-event from)
(define (rewrite-strings #:rewrite rewrite-string los)
(map rewrite-string los))
(define (rewrite-events #:rewrite rewrite-string loe)
(map (rewrite-event #:rewrite rewrite-string) loe))
(define (rewrite-event #:rewrite rewrite-bytes)
(match-lambda
[(struct stdout (b)) (make-stdout (rewrite-bytes from b))]
[(struct stderr (b)) (make-stderr (rewrite-bytes from b))]))
[(struct stdout (b)) (make-stdout (rewrite-bytes b))]
[(struct stderr (b)) (make-stderr (rewrite-bytes b))]))
(define (rewrite-string from s)
(regexp-replace* from s "<current-rev>"))
(define rewrite-bytes rewrite-string)
(define rewrite-string/c
((or/c string? bytes?) . -> . (or/c string? bytes?)))
(provide/contract
[rewrite-status (status? . -> . status?)])
[rewrite-string/c contract?]
[rewrite-status (#:rewrite rewrite-string/c status? . -> . status?)])

24
collects/meta/drdr/run-collect.ss
View File

@ -2,6 +2,7 @@
(require "status.ss"
"notify.ss"
"rewriting.ss"
"dirstruct.ss"
"cache.ss")
(define (command+args+env->command+args
@ -97,6 +98,17 @@
final-status))
(define-syntax regexp-replace**
(syntax-rules ()
[(_ () s) s]
[(_ ([pat0 subst0]
[pat subst]
...)
s)
(regexp-replace* pat0
(regexp-replace** ([pat subst] ...) s)
subst0)]))
(define (run/collect/wait/log log-path command
#:timeout timeout
#:env env
@ -105,8 +117,20 @@
(cache/file
log-path
(lambda ()
(define rev (number->string (current-rev)))
(define home (hash-ref env "HOME"))
(define tmp (hash-ref env "TMPDIR"))
(define cwd (path->string (current-directory)))
(define (rewrite s)
(regexp-replace** ([rev "<current-rev>"]
[home "<home>"]
[tmp "<tmp>"]
[cwd "<cwd>"])
s))
(set! ran? #t)
(rewrite-status
#:rewrite rewrite
(run/collect/wait
#:timeout timeout
#:env env

10
src/racket/src/places.c
View File

@ -36,6 +36,7 @@ static void register_traversers(void);
# endif
static void *place_start_proc(void *arg);
static void *place_start_proc_after_stack(void *data_arg, void *stack_base);
# define PLACE_PRIM_W_ARITY(name, func, a1, a2, env) GLOBAL_PRIM_W_ARITY(name, func, a1, a2, env)
@ -608,6 +609,14 @@ Scheme_Struct_Type *scheme_make_prefab_struct_type_in_master(Scheme_Object *base
static void *place_start_proc(void *data_arg) {
void *stack_base;
void *rc;
stack_base = PROMPT_STACK(stack_base);
rc = place_start_proc_after_stack(data_arg, stack_base);
stack_base = NULL;
return rc;
}
static void *place_start_proc_after_stack(void *data_arg, void *stack_base) {
Place_Start_Data *place_data;
Scheme_Object *place_main;
Scheme_Object *a[2], *channel;
@ -615,7 +624,6 @@ static void *place_start_proc(void *data_arg) {
long rc = 0;
ptid = mz_proc_thread_self();
stack_base = PROMPT_STACK(stack_base);
place_data = (Place_Start_Data *) data_arg;
data_arg = NULL;