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