basis-library/mlton/signal.sml

   1 (* Copyright (C) 2015 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 MLtonSignal: MLTON_SIGNAL_EXTRA =
  11 struct
  12
  13 open Posix.Signal
  14 structure Prim = PrimitiveFFI.Posix.Signal
  15 structure Error = PosixError
  16 structure SysCall = Error.SysCall
  17 val restart = SysCall.restartFlag
  18
  19 type t = signal
  20
  21 type how = C_Int.t
  22
  23 fun raiseInval () =
  24    let
  25       open PosixError
  26    in
  27       raiseSys inval
  28    end
  29
  30 structure Mask =
  31    struct
  32       type pre_sig_set = Word8.word array
  33       type sig_set = Word8.word vector
  34       fun newSigSet (): (pre_sig_set * (unit -> sig_set)) =
  35          let
  36             val sslen = C_Size.toInt Prim.sigSetLen
  37             val ss = Array.array (sslen, 0wx0: Word8.word)
  38          in
  39             (ss, fn () => Array.vector ss)
  40          end
  41
  42       type t = sig_set
  43
  44       fun allBut sigs =
  45          let
  46             val (ss, finish) = newSigSet ()
  47             val () = SysCall.simple (fn () => Prim.sigfillset ss)
  48             val () = List.app (fn s => SysCall.simple
  49                                        (fn () => Prim.sigdelset (ss, toRep s)))
  50                               sigs
  51          in
  52             finish ()
  53          end
  54       val all = allBut []
  55       fun some sigs =
  56          let
  57             val (ss, finish) = newSigSet ()
  58             val () = SysCall.simple (fn () => Prim.sigemptyset ss)
  59             val () = List.app (fn s => SysCall.simple
  60                                        (fn () => Prim.sigaddset (ss, toRep s)))
  61                               sigs
  62          in
  63             finish ()
  64          end
  65       val none = some []
  66
  67       fun isMember (ss, s) =
  68          SysCall.simpleResult (fn () => Prim.sigismember (ss, toRep s)) <> C_Int.zero
  69
  70       local
  71          fun make (how: how) (ss: t) =
  72             let
  73                val (oss, finish) = newSigSet ()
  74                val () = SysCall.simpleRestart (fn () => Prim.sigprocmask (how, ss, oss))
  75             in
  76                finish ()
  77             end
  78       in
  79          val block = ignore o make Prim.SIG_BLOCK
  80          val unblock = ignore o make Prim.SIG_UNBLOCK
  81          val setBlocked = ignore o make Prim.SIG_SETMASK
  82          fun getBlocked () = make Prim.SIG_BLOCK none
  83       end
  84    end
  85
  86 structure Handler =
  87    struct
  88       datatype t =
  89          Default
  90        | Handler of MLtonThread.Runnable.t -> MLtonThread.Runnable.t
  91        | Ignore
  92        | InvalidSignal
  93    end
  94
  95 datatype handler = datatype Handler.t
  96
  97 local
  98    val r = ref C_Int.zero
  99 in
 100    fun initHandler (s: signal): Handler.t =
 101       SysCall.syscallErr
 102       ({clear = false, restart = false, errVal = C_Int.fromInt ~1}, fn () =>
 103        {return = Prim.isDefault (toRep s, r),
 104         post = fn _ => if !r <> C_Int.zero then Default else Ignore,
 105         handlers = [(Error.inval, fn () => InvalidSignal)]})
 106 end
 107
 108 val (getHandler, setHandler, handlers) =
 109    let
 110       val handlers = Array.tabulate (C_Int.toInt Prim.NSIG, initHandler o fromInt)
 111       val _ =
 112          Cleaner.addNew
 113          (Cleaner.atLoadWorld, fn () =>
 114           Array.modifyi (initHandler o fromInt o #1) handlers)
 115    in
 116       (fn s: t => Array.sub (handlers, toInt s),
 117        fn (s: t, h) => if Primitive.MLton.Profile.isOn andalso s = prof
 118                           then raiseInval ()
 119                        else Array.update (handlers, toInt s, h),
 120        handlers)
 121    end
 122
 123 val gcHandler = ref Ignore
 124
 125 fun handled () =
 126    Mask.some
 127    (Array.foldri
 128     (fn (s, h, sigs) =>
 129      case h of
 130         Handler _ => (fromInt s)::sigs
 131       | _ => sigs) [] handlers)
 132
 133 structure Handler =
 134    struct
 135       open Handler
 136
 137       val default = Default
 138       val ignore = Ignore
 139
 140       val isDefault = fn Default => true | _ => false
 141       val isIgnore = fn Ignore => true | _ => false
 142
 143       val handler =
 144          (* This let is used so that Thread.setHandler is only used if
 145           * Handler.handler is used.  This prevents threads from being part
 146           * of every program.
 147           *)
 148          let
 149             (* As far as C is concerned, there is only one signal handler.
 150              * As soon as possible after a C signal is received, this signal
 151              * handler walks over the array of all SML handlers, and invokes any
 152              * one for which a C signal has been received.
 153              *
 154              * Any exceptions raised by a signal handler will be caught by
 155              * the topLevelHandler, which is installed in thread.sml.
 156              *)
 157             val _ =
 158                PosixError.SysCall.blocker :=
 159                (fn () => let
 160                             val m = Mask.getBlocked ()
 161                             val () = Mask.block (handled ())
 162                          in
 163                             fn () => Mask.setBlocked m
 164                          end)
 165
 166             val () =
 167                MLtonThread.setSignalHandler
 168                (fn t =>
 169                 let
 170                    val mask = Mask.getBlocked ()
 171                    val () = Mask.block (handled ())
 172                    val fs =
 173                       case !gcHandler of
 174                          Handler f => if Prim.isPendingGC () <> C_Int.zero
 175                                          then [f]
 176                                          else []
 177                        | _ => []
 178                    val fs =
 179                       Array.foldri
 180                       (fn (s, h, fs) =>
 181                        case h of
 182                           Handler f =>
 183                              if Prim.isPending (repFromInt s) <> C_Int.zero
 184                                 then f::fs
 185                                 else fs
 186                         | _ => fs) fs handlers
 187                    val () = Prim.resetPending ()
 188                    val () = Mask.setBlocked mask
 189                 in
 190                    List.foldl (fn (f, t) => f t) t fs
 191                 end)
 192          in
 193             Handler
 194          end
 195
 196       fun simple (f: unit -> unit) = handler (fn t => (f (); t))
 197    end
 198
 199 val setHandler = fn (s, h) =>
 200    case (getHandler s, h) of
 201       (InvalidSignal, _) => raiseInval ()
 202     | (_, InvalidSignal) => raiseInval ()
 203     | (Default, Default) => ()
 204     | (_, Default) =>
 205          (setHandler (s, Default)
 206           ; SysCall.simpleRestart (fn () => Prim.default (toRep s)))
 207     | (Handler _, Handler _) =>
 208          setHandler (s, h)
 209     | (_, Handler _) =>
 210          (setHandler (s, h)
 211           ; SysCall.simpleRestart (fn () => Prim.handlee (toRep s)))
 212     | (Ignore, Ignore) => ()
 213     | (_, Ignore) =>
 214          (setHandler (s, Ignore)
 215           ; SysCall.simpleRestart (fn () => Prim.ignore (toRep s)))
 216
 217 fun suspend m =
 218    (Prim.sigsuspend m
 219     ; MLtonThread.switchToSignalHandler ())
 220
 221 fun handleGC f =
 222    (Prim.handleGC ()
 223     ; gcHandler := Handler.simple f)
 224
 225 end