From ef535cf476d2cee3abadd3ca7b68f4ebc495228c Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@ccs.neu.edu>
Date: Mon, 18 Aug 2014 21:19:52 -0400
Subject: [PATCH] fix resource administration in run and launch-many-worlds

the goal is to enable the creation from executables from world and universe programs
---
 .../2htdp/private/launch-many-worlds.rkt      | 66 +++++++++----------
 pkgs/htdp-pkgs/htdp-lib/2htdp/universe.rkt    |  4 ++
 2 files changed, 34 insertions(+), 36 deletions(-)

diff --git a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/launch-many-worlds.rkt b/pkgs/htdp-pkgs/htdp-lib/2htdp/private/launch-many-worlds.rkt
index 88da624f20..d84f148b8b 100644
--- a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/launch-many-worlds.rkt
+++ b/pkgs/htdp-pkgs/htdp-lib/2htdp/private/launch-many-worlds.rkt
@@ -1,8 +1,5 @@
 #lang racket/base
 
-(require racket/list racket/function racket/gui
-         mzlib/etc htdp/error)
-
 (provide
  ;; (launch-many-worlds e1 ... e2)
  ;; run expressions e1 through e2 in parallel,
@@ -11,46 +8,43 @@
  ;; launch-many-worlds/proc : (-> Any) *-> [Listof Any]
  launch-many-worlds/proc)
 
+;; ---------------------------------------------------------------------------------------------------
+(require racket/list racket/function racket/gui mzlib/etc htdp/error)
+
 (define-syntax-rule 
   (launch-many-worlds e ...) 
   (launch-many-worlds* (lambda () e) ...))
 
 (define (launch-many-worlds/proc . loth)
-  ;; check args 
+  ;; check arguments:
   (for ([th loth][i (in-naturals 1)])
     (check-proc 'launch-many-worlds/proc th 0 i "no arguments"))
+  ;; -- IN -- 
   (apply launch-many-worlds* loth))
 
 ;; [Listof (-> X)] ->* X ...
-(define (launch-many-worlds* . loth)
-  (let* ([c* (make-custodian)]
-         [ch (make-channel)]
-         [pu (curry channel-put ch)]
-         [th (map (lambda (th i)
-                    (parameterize ([current-custodian c*])
-                      (rec t
-                        (thread
-                         (lambda ()
-                           (with-handlers ((exn? pu)) (pu (list i t (th)))))))))
-                  loth
-                  (build-list (length loth) (lambda (i) i)))])
-    (letrec ([L (lambda (th r*)
-                  (if (null? th)
-                      (apply values (map third (sort r* < #:key first)))
-                      (sync 
-                       (handle-evt 
-                        ch 
-                        (lambda (x)
-                          (if (exn? x)
-                              (begin
-                                (custodian-shutdown-all c*)
-                                (raise x))
-                              (L (remq (second x) th) (cons x r*))))))))])
-      (with-handlers ((exn:break? (lambda (xn) (custodian-shutdown-all c*))))
-        (L th '())))))
-
-;; some silly tests
-
-; (launch-many-worlds 1 2 3)
-
-; (launch-many-worlds 1 (let loop ([n 100]) (printf "~s\n" n) (sleep 1) (loop n)) 3)
+;; run the thunks as parallel threads and produce 'values' of their results
+;; effect: propagate exn when one of them raises one 
+(define (launch-many-worlds* . th*)
+  ;; allocate the program's resources in the active custodian 
+  (define cc (current-custodian))
+  ;; c* is used to shut down launch-many-worlds when one of them raises an exn
+  [define c* (make-custodian)]
+  [define ch (make-channel)]
+  (parameterize ([current-custodian c*]) 
+    (for/list ((th th*) (i (in-naturals)))
+      (parameterize ([current-eventspace (make-eventspace)])
+        (queue-callback
+         (lambda ()
+           (with-handlers ((exn? (lambda (x) (channel-put ch x))))
+             (channel-put ch (list i (parameterize ([current-custodian cc]) (th))))))))))
+  ;; for all X: (U Exn X) -> X
+  (define (handle x)
+    (when (exn? x) (custodian-shutdown-all c*) (raise x))
+    x)
+  ;; [Listof X]
+  (define results
+     (for/list ((n (in-range (length th*))))
+      (sync (handle-evt ch handle))))
+  ;; -- IN -- 
+  (apply values (map second (sort results < #:key first))))
diff --git a/pkgs/htdp-pkgs/htdp-lib/2htdp/universe.rkt b/pkgs/htdp-pkgs/htdp-lib/2htdp/universe.rkt
index fd7c93b0fb..51200c5f13 100644
--- a/pkgs/htdp-pkgs/htdp-lib/2htdp/universe.rkt
+++ b/pkgs/htdp-pkgs/htdp-lib/2htdp/universe.rkt
@@ -423,6 +423,10 @@
 ;                                          
 
 ;; (-> Object) -> Any
+(define (run-it o)
+  (send (o) last))
+
+#;
 (define (run-it o)
   (define esp (make-eventspace))
   (define thd (eventspace-handler-thread esp))