basis-library/mlton/world.sml

   1 (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  * Copyright (C) 1997-2000 NEC Research Institute.
   4  *
   5  * MLton is released under a BSD-style license.
   6  * See the file MLton-LICENSE for details.
   7  *)
   8
   9 structure MLtonWorld: MLTON_WORLD =
  10    struct
  11       structure Prim = Primitive.MLton.World
  12       structure Error = PosixError
  13       structure SysCall = Error.SysCall
  14
  15       val gcState = Primitive.MLton.GCState.gcState
  16
  17       datatype status = Clone | Original
  18
  19       (* Need to worry about:
  20        *   - open file descriptors
  21        *   - redetermine buffer status when restart
  22        *)
  23       fun save' (file: string): status =
  24          let
  25             val () =
  26                SysCall.simple'
  27                ({errVal = false},
  28                 fn () => (Prim.save (NullString.nullTerm file)
  29                           ; Prim.getSaveStatus (gcState)))
  30          in
  31             if Prim.getAmOriginal gcState
  32                then Original
  33             else (Prim.setAmOriginal (gcState, true)
  34                   ; Cleaner.clean Cleaner.atLoadWorld
  35                   ; Clone)
  36          end
  37
  38       fun saveThread (file: string, t: MLtonThread.Runnable.t): unit =
  39          case save' file of
  40             Clone => MLtonThread.switch (fn _ => t)
  41           | Original => ()
  42
  43       fun save (file: string): status =
  44          if MLtonThread.amInSignalHandler ()
  45             then raise Fail "cannot call MLton.World.save within signal handler"
  46          else save' file
  47
  48       fun load (file: string): 'a =
  49          if let open OS_FileSys
  50             in access (file, [A_READ])
  51             end
  52             then
  53                let val c = CommandLine.name ()
  54                in Posix.Process.exec (c, [c, "@MLton", "load-world", file, "--"])
  55                end
  56          else raise Fail (concat ["World.load can not read ", file])
  57    end