fix resource administration in run and launch-many-worlds

the goal is to enable the creation from executables from world and universe programs

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)
+;; run the thunks as parallel threads and produce 'values' of their results
-  (let* ([c* (make-custodian)]
+;; effect: propagate exn when one of them raises one 
-         [ch (make-channel)]
+(define (launch-many-worlds* . th*)
-         [pu (curry channel-put ch)]
+  ;; allocate the program's resources in the active custodian 
-         [th (map (lambda (th i)
+  (define cc (current-custodian))
-                    (parameterize ([current-custodian c*])
+  ;; c* is used to shut down launch-many-worlds when one of them raises an exn
-                      (rec t
+  [define c* (make-custodian)]
-                        (thread
+  [define ch (make-channel)]
-                         (lambda ()
+  (parameterize ([current-custodian c*]) 
-                           (with-handlers ((exn? pu)) (pu (list i t (th)))))))))
+    (for/list ((th th*) (i (in-naturals)))
-                  loth
+      (parameterize ([current-eventspace (make-eventspace)])
-                  (build-list (length loth) (lambda (i) i)))])
+        (queue-callback
-    (letrec ([L (lambda (th r*)
+         (lambda ()
-                  (if (null? th)
+           (with-handlers ((exn? (lambda (x) (channel-put ch x))))
-                      (apply values (map third (sort r* < #:key first)))
+             (channel-put ch (list i (parameterize ([current-custodian cc]) (th))))))))))
-                      (sync 
+  ;; for all X: (U Exn X) -> X
-                       (handle-evt 
+  (define (handle x)
-                        ch 
+    (when (exn? x) (custodian-shutdown-all c*) (raise x))
-                        (lambda (x)
+    x)
-                          (if (exn? x)
+  ;; [Listof X]
-                              (begin
+  (define results
-                                (custodian-shutdown-all c*)
+     (for/list ((n (in-range (length th*))))
-                                (raise x))
+      (sync (handle-evt ch handle))))
-                              (L (remq (second x) th) (cons x r*))))))))])
+  ;; -- IN -- 
-      (with-handlers ((exn:break? (lambda (xn) (custodian-shutdown-all c*))))
+  (apply values (map second (sort results < #:key first))))
-        (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)

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