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

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))])
+                                                      ["HOME" (make-fresh-home-dir)])
-                                             ; XXX Maybe this should destroy the old home and copy in a new one
-                                             ;     Otherwise it is a source of randomness
                                              (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)
+(define (make-fresh-home-dir)
-  (format "~a~a"
+  (define new-dir (make-temporary-file "home~a" 'directory))
-          (hash-ref (current-env) "HOME")
+  (with-handlers ([exn:fail? void])
-          i))
+    (copy-directory/files (hash-ref (current-env) "HOME") new-dir))
+  (path->string new-dir))
 
 (define (recur-many i r f)
   (if (zero? i)

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])

collects/meta/drdr/rewriting.ss

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

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 "<current-rev>"]
+                          [home "<home>"]
+                          [tmp "<tmp>"]
+                          [cwd "<cwd>"])
+                         s))
+     
      (set! ran? #t)
      (rewrite-status
+      #:rewrite rewrite
       (run/collect/wait
        #:timeout timeout
        #:env env

src/racket/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;