From 8116350df418e321363e2b72d4d75f5bfe7271e3 Mon Sep 17 00:00:00 2001 From: tewk Date: Mon, 19 Apr 2010 15:19:23 -0600 Subject: [PATCH 1/3] [Places] fix stack_base --- src/mzscheme/src/places.c | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/mzscheme/src/places.c b/src/mzscheme/src/places.c index 98bfb012b7..bdfcc6ff86 100644 --- a/src/mzscheme/src/places.c +++ b/src/mzscheme/src/places.c @@ -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; From b065d86b37febde0b209a0e704081a27e0d6b90f Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 20 Apr 2010 14:52:42 -0600 Subject: [PATCH 2/3] Fresh home dir per file and rewriting of more random paths --- collects/meta/drdr/plt-build.ss | 21 +++++---------- collects/meta/drdr/rewriting.ss | 45 ++++++++++++++++--------------- collects/meta/drdr/run-collect.ss | 24 +++++++++++++++++ 3 files changed, 53 insertions(+), 37 deletions(-) diff --git a/collects/meta/drdr/plt-build.ss b/collects/meta/drdr/plt-build.ss index ab206f4d65..d8d93cef3b 100644 --- a/collects/meta/drdr/plt-build.ss +++ b/collects/meta/drdr/plt-build.ss @@ -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) diff --git a/collects/meta/drdr/rewriting.ss b/collects/meta/drdr/rewriting.ss index 01f482d1f0..f0ba0e6a18 100644 --- a/collects/meta/drdr/rewriting.ss +++ b/collects/meta/drdr/rewriting.ss @@ -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 "")) -(define rewrite-bytes rewrite-string) +(define rewrite-string/c + ((or/c string? bytes?) . -> . (or/c string? bytes?))) (provide/contract - [rewrite-status (status? . -> . status?)]) \ No newline at end of file + [rewrite-string/c contract?] + [rewrite-status (#:rewrite rewrite-string/c status? . -> . status?)]) \ No newline at end of file diff --git a/collects/meta/drdr/run-collect.ss b/collects/meta/drdr/run-collect.ss index 93792bac56..c4aaa3d221 100644 --- a/collects/meta/drdr/run-collect.ss +++ b/collects/meta/drdr/run-collect.ss @@ -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 ""] + [home ""] + [tmp ""] + [cwd ""]) + s)) + (set! ran? #t) (rewrite-status + #:rewrite rewrite (run/collect/wait #:timeout timeout #:env env From 782f6c71ee6469fa962ad42ff0c022dbbc16244e Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 20 Apr 2010 14:56:27 -0600 Subject: [PATCH 3/3] Getting build start time from somewhere else so it is monotonic --- collects/meta/drdr/render.ss | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/meta/drdr/render.ss b/collects/meta/drdr/render.ss index acc1699f80..4f1ca701ae 100644 --- a/collects/meta/drdr/render.ss +++ b/collects/meta/drdr/render.ss @@ -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])