regression/world5.sml

   1 fun run (f: unit -> unit) =
   2    case Posix.Process.fork () of
   3       SOME pid =>
   4          let
   5             open Posix.Process
   6             val (pid', status) = waitpid (W_CHILD pid, [])
   7          in if pid = pid' andalso status = W_EXITED
   8                then ()
   9             else raise Fail "child failed"
  10          end
  11     | NONE => let open OS.Process
  12               in exit ((f (); success) handle _ => failure)
  13               end
  14
  15 fun succeed () =
  16    let open OS.Process
  17    in exit success
  18    end
  19
  20 open MLton.World MLton.Signal Posix.Signal Posix.Process Posix.ProcEnv
  21
  22 val (w, out) = MLton.TextIO.mkstemp "/tmp/world"
  23 val _ = TextIO.closeOut out
  24
  25 val childReady = ref false
  26
  27 fun print s = TextIO.output (TextIO.stdErr, s)
  28
  29 val _ = setHandler (usr1, Handler.simple (fn () => childReady := true))
  30
  31 val parent = getpid ()
  32
  33 val _ =
  34    case fork () of
  35       NONE =>
  36          let
  37             val canExit = ref false
  38          in
  39             setHandler (usr1, Handler.handler (fn t => (canExit := true
  40                                                         ; saveThread (w, t)
  41                                                         ; t)))
  42             ; kill (K_PROC parent, usr1)
  43             ; let
  44                  fun loop () = if !canExit then print "success\n" else loop ()
  45               in
  46                  loop ()
  47               end
  48             ; let open OS.Process
  49               in exit success
  50               end
  51          end
  52     | SOME child =>
  53          let
  54             fun loop () = if !childReady then () else loop ()
  55          in
  56             loop ()
  57             ; kill (K_PROC child, usr1)
  58             ; wait ()
  59             ; run (fn () => load w)
  60             ; OS.FileSys.remove w
  61          end