basis-library/posix/process.sml

   1 (* Copyright (C) 2009 Matthew Fluet.
   2  * Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  * Copyright (C) 1997-2000 NEC Research Institute.
   5  *
   6  * MLton is released under a BSD-style license.
   7  * See the file MLton-LICENSE for details.
   8  *)
   9
  10 structure PosixProcess: POSIX_PROCESS_EXTRA =
  11    struct
  12       structure Prim = PrimitiveFFI.Posix.Process
  13       open Prim
  14       structure FileDesc = PrePosix.FileDesc
  15       structure PId = PrePosix.PId
  16       structure Signal = PrePosix.Signal
  17
  18       structure Error = PosixError
  19       structure SysCall = Error.SysCall
  20
  21       type signal = Signal.t
  22       type pid = PId.t
  23
  24       val pidToWord = C_PId.castToSysWord o PId.toRep
  25       val wordToPid = PId.fromRep o C_PId.castFromSysWord
  26
  27       fun fork () =
  28          SysCall.syscall'
  29          ({errVal = C_PId.castFromFixedInt ~1}, fn () =>
  30           (Prim.fork (), fn p =>
  31            if p = C_PId.castFromFixedInt 0
  32               then NONE
  33            else SOME (PId.fromRep p)))
  34
  35       val fork =
  36          if Primitive.MLton.Platform.OS.forkIsEnabled
  37             then fork
  38          else fn () => Error.raiseSys Error.nosys
  39
  40       val conv = NullString.nullTerm
  41       val convs = CUtil.C_StringArray.fromList
  42
  43       fun exece (path, args, env): 'a =
  44          let
  45             val path = conv path
  46             val args = convs args
  47             val env = convs env
  48          in
  49             (SysCall.simple
  50              (fn () => Prim.exece (path, args, env))
  51              ; raise Fail "Posix.Process.exece")
  52          end
  53
  54       fun exec (path, args): 'a =
  55          exece (path, args, PosixProcEnv.environ ())
  56
  57       fun execp (file, args): 'a =
  58          let
  59             val file = conv file
  60             val args = convs args
  61          in
  62             (SysCall.simple
  63              (fn () => Prim.execp (file, args))
  64              ; raise Fail "Posix.Process.execp")
  65          end
  66
  67       datatype waitpid_arg =
  68          W_ANY_CHILD
  69        | W_CHILD of pid
  70        | W_SAME_GROUP
  71        | W_GROUP of pid
  72
  73       datatype exit_status =
  74          W_EXITED
  75        | W_EXITSTATUS of Word8.word
  76        | W_SIGNALED of signal
  77        | W_STOPPED of signal
  78
  79       fun fromStatus' (status : C_Status.t) =
  80          if Prim.ifExited status <> C_Int.zero
  81             then (case Prim.exitStatus status of
  82                      0 => W_EXITED
  83                    | n => W_EXITSTATUS (Word8.castFromSysWord (C_Int.castToSysWord n)))
  84          else if Prim.ifSignaled status <> C_Int.zero
  85             then W_SIGNALED (PosixSignal.fromRep (Prim.termSig status))
  86          else if Prim.ifStopped status <> C_Int.zero
  87             then W_STOPPED (PosixSignal.fromRep (Prim.stopSig status))
  88          else raise Fail "Posix.Process.fromStatus"
  89       fun fromStatus status =
  90          fromStatus' (PreOS.Status.toRep status)
  91
  92       structure W =
  93          struct
  94             structure Flags = BitFlags(structure S = C_Int)
  95             open W Flags
  96             (* val continued = CONTINUED *)
  97             val nohang = NOHANG
  98             val untraced = UNTRACED
  99          end
 100
 101       local
 102          val status: C_Status.t ref = ref (C_Status.fromInt 0)
 103          fun wait (wa, status, flags) =
 104             let
 105                val pid =
 106                   case wa of
 107                      W_ANY_CHILD => C_PId.castFromFixedInt ~1
 108                    | W_CHILD pid => PId.toRep pid
 109                    | W_SAME_GROUP => C_PId.castFromFixedInt 0
 110                    | W_GROUP pid => C_PId.~ (PId.toRep pid)
 111                val flags = W.flags flags
 112             in
 113                (PId.fromRep o SysCall.simpleResultRestart')
 114                ({errVal = C_PId.castFromFixedInt ~1}, fn () =>
 115                 let
 116                    val pid = Prim.waitpid (pid, status, flags)
 117                 in
 118                    pid
 119                 end)
 120             end
 121          fun getStatus () = fromStatus' (!status)
 122       in
 123          fun waitpid (wa, flags) =
 124             let
 125                val pid = wait (wa, status, flags)
 126             in
 127                (pid, getStatus ())
 128             end
 129
 130          fun waitpid_nh (wa, flags) =
 131             let
 132                val pid = wait (wa, status, W.nohang :: flags)
 133             in
 134                if PId.fromRep (C_PId.castFromFixedInt 0) = pid
 135                   then NONE
 136                else SOME (pid, getStatus ())
 137             end
 138       end
 139
 140       fun wait () = waitpid (W_ANY_CHILD, [])
 141
 142       fun exit (w: Word8.word): 'a  =
 143          (* Posix.Process.exit does not call atExit cleaners, as per the basis
 144           * library spec.
 145           *)
 146          (Prim.exit (C_Status.castFromSysWord (Word8.castToSysWord w))
 147           ; raise Fail "Posix.Process.exit")
 148
 149       datatype killpid_arg  =
 150          K_PROC of pid
 151        | K_SAME_GROUP
 152        | K_GROUP of pid
 153
 154       fun kill (ka: killpid_arg, s: signal): unit =
 155          let
 156             val pid =
 157                case ka of
 158                   K_PROC pid => PId.toRep pid
 159                 | K_SAME_GROUP => C_PId.castFromFixedInt ~1
 160                 | K_GROUP pid => C_PId.~ (PId.toRep pid)
 161             val s = PosixSignal.toRep s
 162          in
 163             SysCall.simple (fn () => Prim.kill (pid, s))
 164          end
 165
 166       local
 167          fun wrap prim (t: Time.time): Time.time =
 168             Time.fromSeconds
 169             (C_UInt.toLargeInt
 170              (prim
 171               ((C_UInt.fromLargeInt (Time.toSeconds t))
 172                handle Overflow => Error.raiseSys Error.inval)))
 173       in
 174          val alarm = wrap Prim.alarm
 175          (* val sleep = wrap Prim.sleep *)
 176       end
 177
 178       fun sleep (t: Time.time): Time.time =
 179          let
 180             val t = Time.toNanoseconds t
 181             val sec = LargeInt.quot (t, 1000000000)
 182             val nsec = LargeInt.rem (t, 1000000000)
 183             val (sec, nsec) =
 184                (C_Time.fromLargeInt sec, C_Long.fromLargeInt nsec)
 185                handle Overflow => Error.raiseSys Error.inval
 186             val secRem = ref sec
 187             val nsecRem = ref nsec
 188             fun remaining _ =
 189                Time.+ (Time.fromSeconds (C_Time.toLargeInt (!secRem)),
 190                        Time.fromNanoseconds (C_Long.toLargeInt (!nsecRem)))
 191          in
 192             SysCall.syscallErr
 193             ({clear = false, restart = false, errVal = C_Int.fromInt ~1}, fn () =>
 194              {handlers = [(Error.intr, remaining)],
 195               post = remaining,
 196               return = Prim.nanosleep (secRem, nsecRem)})
 197          end
 198
 199       (* FIXME: pause *)
 200       fun pause () =
 201          SysCall.syscallErr
 202          ({clear = false, restart = false, errVal = C_Int.fromInt ~1},
 203           fn () =>
 204           {return = Prim.pause (),
 205            post = fn _ => (),
 206            handlers = [(Error.intr, fn () => ())]})
 207    end