Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 1999-2008 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 PosixError: POSIX_ERROR_EXTRA = | |
10 | struct | |
11 | structure Prim = PrimitiveFFI.Posix.Error | |
12 | open Prim | |
13 | structure SysError = PrePosix.SysError | |
14 | ||
15 | type syserror = SysError.t | |
16 | ||
17 | val acces = SysError.fromRep EACCES | |
18 | val addrinuse = SysError.fromRep EADDRINUSE | |
19 | val addrnotavail = SysError.fromRep EADDRNOTAVAIL | |
20 | val afnosupport = SysError.fromRep EAFNOSUPPORT | |
21 | val again = SysError.fromRep EAGAIN | |
22 | val already = SysError.fromRep EALREADY | |
23 | val badf = SysError.fromRep EBADF | |
24 | val badmsg = SysError.fromRep EBADMSG | |
25 | val busy = SysError.fromRep EBUSY | |
26 | val canceled = SysError.fromRep ECANCELED | |
27 | val child = SysError.fromRep ECHILD | |
28 | val connaborted = SysError.fromRep ECONNABORTED | |
29 | val connrefused = SysError.fromRep ECONNREFUSED | |
30 | val connreset = SysError.fromRep ECONNRESET | |
31 | val deadlk = SysError.fromRep EDEADLK | |
32 | val destaddrreq = SysError.fromRep EDESTADDRREQ | |
33 | val dom = SysError.fromRep EDOM | |
34 | val dquot = SysError.fromRep EDQUOT | |
35 | val exist = SysError.fromRep EEXIST | |
36 | val fault = SysError.fromRep EFAULT | |
37 | val fbig = SysError.fromRep EFBIG | |
38 | val hostunreach = SysError.fromRep EHOSTUNREACH | |
39 | val idrm = SysError.fromRep EIDRM | |
40 | val ilseq = SysError.fromRep EILSEQ | |
41 | val inprogress = SysError.fromRep EINPROGRESS | |
42 | val intr = SysError.fromRep EINTR | |
43 | val inval = SysError.fromRep EINVAL | |
44 | val io = SysError.fromRep EIO | |
45 | val isconn = SysError.fromRep EISCONN | |
46 | val isdir = SysError.fromRep EISDIR | |
47 | val loop = SysError.fromRep ELOOP | |
48 | val mfile = SysError.fromRep EMFILE | |
49 | val mlink = SysError.fromRep EMLINK | |
50 | val msgsize = SysError.fromRep EMSGSIZE | |
51 | val multihop = SysError.fromRep EMULTIHOP | |
52 | val nametoolong = SysError.fromRep ENAMETOOLONG | |
53 | val netdown = SysError.fromRep ENETDOWN | |
54 | val netreset = SysError.fromRep ENETRESET | |
55 | val netunreach = SysError.fromRep ENETUNREACH | |
56 | val nfile = SysError.fromRep ENFILE | |
57 | val nobufs = SysError.fromRep ENOBUFS | |
58 | val nodata = SysError.fromRep ENODATA | |
59 | val nodev = SysError.fromRep ENODEV | |
60 | val noent = SysError.fromRep ENOENT | |
61 | val noexec = SysError.fromRep ENOEXEC | |
62 | val nolck = SysError.fromRep ENOLCK | |
63 | val nolink = SysError.fromRep ENOLINK | |
64 | val nomem = SysError.fromRep ENOMEM | |
65 | val nomsg = SysError.fromRep ENOMSG | |
66 | val noprotoopt = SysError.fromRep ENOPROTOOPT | |
67 | val nospc = SysError.fromRep ENOSPC | |
68 | val nosr = SysError.fromRep ENOSR | |
69 | val nostr = SysError.fromRep ENOSTR | |
70 | val nosys = SysError.fromRep ENOSYS | |
71 | val notconn = SysError.fromRep ENOTCONN | |
72 | val notdir = SysError.fromRep ENOTDIR | |
73 | val notempty = SysError.fromRep ENOTEMPTY | |
74 | val notsock = SysError.fromRep ENOTSOCK | |
75 | val notsup = SysError.fromRep ENOTSUP | |
76 | val notty = SysError.fromRep ENOTTY | |
77 | val nxio = SysError.fromRep ENXIO | |
78 | val opnotsupp = SysError.fromRep EOPNOTSUPP | |
79 | val overflow = SysError.fromRep EOVERFLOW | |
80 | val perm = SysError.fromRep EPERM | |
81 | val pipe = SysError.fromRep EPIPE | |
82 | val proto = SysError.fromRep EPROTO | |
83 | val protonosupport = SysError.fromRep EPROTONOSUPPORT | |
84 | val prototype = SysError.fromRep EPROTOTYPE | |
85 | val range = SysError.fromRep ERANGE | |
86 | val rofs = SysError.fromRep EROFS | |
87 | val spipe = SysError.fromRep ESPIPE | |
88 | val srch = SysError.fromRep ESRCH | |
89 | val stale = SysError.fromRep ESTALE | |
90 | val time = SysError.fromRep ETIME | |
91 | val timedout = SysError.fromRep ETIMEDOUT | |
92 | val toobig = SysError.fromRep E2BIG | |
93 | val txtbsy = SysError.fromRep ETXTBSY | |
94 | val wouldblock = SysError.fromRep EWOULDBLOCK | |
95 | val xdev = SysError.fromRep EXDEV | |
96 | ||
97 | local | |
98 | infixr 5 ::? | |
99 | fun (n,s) ::? l = | |
100 | if n = SysError.fromRep ~1 | |
101 | then l | |
102 | else (n,s) :: l | |
103 | in | |
104 | val errorNames = | |
105 | (acces,"acces") ::? | |
106 | (addrinuse,"addrinuse") ::? | |
107 | (addrnotavail,"addrnotavail") ::? | |
108 | (afnosupport,"afnosupport") ::? | |
109 | (again,"again") ::? | |
110 | (already,"already") ::? | |
111 | (badf,"badf") ::? | |
112 | (badmsg,"badmsg") ::? | |
113 | (busy,"busy") ::? | |
114 | (canceled,"canceled") ::? | |
115 | (child,"child") ::? | |
116 | (connaborted,"connaborted") ::? | |
117 | (connrefused,"connrefused") ::? | |
118 | (connreset,"connreset") ::? | |
119 | (deadlk,"deadlk") ::? | |
120 | (destaddrreq,"destaddrreq") ::? | |
121 | (dom,"dom") ::? | |
122 | (dquot,"dquot") ::? | |
123 | (exist,"exist") ::? | |
124 | (fault,"fault") ::? | |
125 | (fbig,"fbig") ::? | |
126 | (hostunreach,"hostunreach") ::? | |
127 | (idrm,"idrm") ::? | |
128 | (ilseq,"ilseq") ::? | |
129 | (inprogress,"inprogress") ::? | |
130 | (intr,"intr") ::? | |
131 | (inval,"inval") ::? | |
132 | (io,"io") ::? | |
133 | (isconn,"isconn") ::? | |
134 | (isdir,"isdir") ::? | |
135 | (loop,"loop") ::? | |
136 | (mfile,"mfile") ::? | |
137 | (mlink,"mlink") ::? | |
138 | (msgsize,"msgsize") ::? | |
139 | (multihop,"multihop") ::? | |
140 | (nametoolong,"nametoolong") ::? | |
141 | (netdown,"netdown") ::? | |
142 | (netreset,"netreset") ::? | |
143 | (netunreach,"netunreach") ::? | |
144 | (nfile,"nfile") ::? | |
145 | (nobufs,"nobufs") ::? | |
146 | (nodata,"nodata") ::? | |
147 | (nodev,"nodev") ::? | |
148 | (noent,"noent") ::? | |
149 | (noexec,"noexec") ::? | |
150 | (nolck,"nolck") ::? | |
151 | (nolink,"nolink") ::? | |
152 | (nomem,"nomem") ::? | |
153 | (nomsg,"nomsg") ::? | |
154 | (noprotoopt,"noprotoopt") ::? | |
155 | (nospc,"nospc") ::? | |
156 | (nosr,"nosr") ::? | |
157 | (nostr,"nostr") ::? | |
158 | (nosys,"nosys") ::? | |
159 | (notconn,"notconn") ::? | |
160 | (notdir,"notdir") ::? | |
161 | (notempty,"notempty") ::? | |
162 | (notsock,"notsock") ::? | |
163 | (notsup,"notsup") ::? | |
164 | (notty,"notty") ::? | |
165 | (nxio,"nxio") ::? | |
166 | (opnotsupp,"opnotsupp") ::? | |
167 | (overflow,"overflow") ::? | |
168 | (perm,"perm") ::? | |
169 | (pipe,"pipe") ::? | |
170 | (proto,"proto") ::? | |
171 | (protonosupport,"protonosupport") ::? | |
172 | (prototype,"prototype") ::? | |
173 | (range,"range") ::? | |
174 | (rofs,"rofs") ::? | |
175 | (spipe,"spipe") ::? | |
176 | (srch,"srch") ::? | |
177 | (stale,"stale") ::? | |
178 | (time,"time") ::? | |
179 | (timedout,"timedout") ::? | |
180 | (toobig,"toobig") ::? | |
181 | (txtbsy,"txtbsy") ::? | |
182 | (wouldblock,"wouldblock") ::? | |
183 | (xdev,"xdev") ::? | |
184 | [] | |
185 | end | |
186 | exception SysErr of string * syserror option | |
187 | ||
188 | val toWord = C_Int.castToSysWord o SysError.toRep | |
189 | val fromWord = SysError.fromRep o C_Int.castFromSysWord | |
190 | ||
191 | val cleared : syserror = SysError.fromRep 0 | |
192 | ||
193 | fun errorName n = | |
194 | case List.find (fn (m, _) => n = m) errorNames of | |
195 | NONE => "<UNKNOWN>" | |
196 | | SOME (_, s) => s | |
197 | ||
198 | val _ = | |
199 | General.addExnMessager | |
200 | (fn e => | |
201 | case e of | |
202 | SysErr (s, eo) => | |
203 | SOME (concat ["SysErr: ", s, | |
204 | case eo of | |
205 | NONE => "" | |
206 | | SOME e => concat [" [", errorName e, "]"]]) | |
207 | | _ => NONE) | |
208 | ||
209 | fun syserror s = | |
210 | case List.find (fn (_, s') => s = s') errorNames of | |
211 | NONE => NONE | |
212 | | SOME (n, _) => SOME n | |
213 | ||
214 | fun errorMsg (n: syserror) = | |
215 | let | |
216 | val cs = strError (SysError.toRep n) | |
217 | in | |
218 | if Primitive.MLton.Pointer.isNull | |
219 | (Primitive.MLton.Pointer.fromWord cs) | |
220 | then "Unknown error" | |
221 | else CUtil.C_String.toString cs | |
222 | end | |
223 | ||
224 | fun raiseSys n = raise SysErr (errorMsg n, SOME n) | |
225 | fun raiseSysWithMsg (n, msg) = raise SysErr ((errorMsg n) ^ ": " ^ msg, SOME n) | |
226 | ||
227 | structure SysCall = | |
228 | struct | |
229 | structure Thread = Primitive.MLton.Thread | |
230 | ||
231 | val blocker: (unit -> (unit -> unit)) ref = | |
232 | ref (fn () => (fn () => ())) | |
233 | (* ref (fn () => raise Fail "blocker not installed") *) | |
234 | val restartFlag = ref true | |
235 | ||
236 | val syscallErr: {clear: bool, restart: bool, errVal: ''a} * | |
237 | (unit -> {return: ''a C_Errno.t, | |
238 | post: ''a -> 'b, | |
239 | handlers: (syserror * (unit -> 'b)) list}) -> 'b = | |
240 | fn ({clear, restart, errVal}, f) => | |
241 | let | |
242 | fun call (err: {errno: syserror, | |
243 | handlers: (syserror * (unit -> 'b)) list} -> 'b): 'b = | |
244 | let | |
245 | val () = Thread.atomicBegin () | |
246 | val () = if clear then clearErrno () else () | |
247 | val {return, post, handlers} = | |
248 | f () handle exn => (Thread.atomicEnd (); raise exn) | |
249 | val return = C_Errno.check return | |
250 | in | |
251 | if errVal = return | |
252 | then | |
253 | (* Must getErrno () in the critical section. *) | |
254 | let | |
255 | val e = SysError.fromRep (getErrno ()) | |
256 | val () = Thread.atomicEnd () | |
257 | in | |
258 | err {errno = e, handlers = handlers} | |
259 | end | |
260 | else DynamicWind.wind (fn () => post return , Thread.atomicEnd) | |
261 | end | |
262 | fun err {default: unit -> 'b, | |
263 | errno: syserror, | |
264 | handlers: (syserror * (unit -> 'b)) list}: 'b = | |
265 | case List.find (fn (e',_) => errno = e') handlers of | |
266 | NONE => default () | |
267 | | SOME (_, handler) => handler () | |
268 | fun errBlocked {errno: syserror, | |
269 | handlers: (syserror * (unit -> 'b)) list}: 'b = | |
270 | err {default = fn () => raiseSys errno, | |
271 | errno = errno, handlers = handlers} | |
272 | fun errUnblocked | |
273 | {errno: syserror, | |
274 | handlers: (syserror * (unit -> 'b)) list}: 'b = | |
275 | err {default = fn () => | |
276 | if restart andalso errno = intr andalso !restartFlag | |
277 | then if Thread.atomicState () = 0w0 | |
278 | then call errUnblocked | |
279 | else let val finish = !blocker () | |
280 | in | |
281 | DynamicWind.wind | |
282 | (fn () => call errBlocked, finish) | |
283 | end | |
284 | else raiseSys errno, | |
285 | errno = errno, handlers = handlers} | |
286 | in | |
287 | call errUnblocked | |
288 | end | |
289 | ||
290 | local | |
291 | val simpleResultAux = fn ({restart, errVal}, f) => | |
292 | syscallErr | |
293 | ({clear = false, restart = restart, errVal = errVal}, fn () => | |
294 | let val return = f () | |
295 | in {return = return, | |
296 | post = fn ret => ret, | |
297 | handlers = []} | |
298 | end) | |
299 | in | |
300 | val simpleResultRestart = fn f => | |
301 | simpleResultAux ({restart = true, errVal = C_Int.fromInt ~1}, f) | |
302 | val simpleResult = fn f => | |
303 | simpleResultAux ({restart = false, errVal = C_Int.fromInt ~1}, f) | |
304 | ||
305 | val simpleResultRestart' = fn ({errVal}, f) => | |
306 | simpleResultAux ({restart = true, errVal = errVal}, f) | |
307 | val simpleResult' = fn ({errVal}, f) => | |
308 | simpleResultAux ({restart = false, errVal = errVal}, f) | |
309 | end | |
310 | ||
311 | val simpleRestart = ignore o simpleResultRestart | |
312 | val simple = ignore o simpleResult | |
313 | ||
314 | val simpleRestart' = fn ({errVal}, f) => | |
315 | ignore (simpleResultRestart' ({errVal = errVal}, f)) | |
316 | val simple' = fn ({errVal}, f) => | |
317 | ignore (simpleResult' ({errVal = errVal}, f)) | |
318 | ||
319 | val syscallRestart' = fn ({errVal}, f) => | |
320 | syscallErr | |
321 | ({clear = false, restart = true, errVal = errVal}, fn () => | |
322 | let val (return, post) = f () | |
323 | in {return = return, post = post, handlers = []} | |
324 | end) | |
325 | val syscall' = fn ({errVal}, f) => | |
326 | syscallErr | |
327 | ({clear = false, restart = false, errVal = errVal}, fn () => | |
328 | let val (return, post) = f () | |
329 | in {return = return, post = post, handlers = []} | |
330 | end) | |
331 | val syscallRestart = fn f => | |
332 | syscallRestart' ({errVal = C_Int.fromInt ~1}, f) | |
333 | val syscall = fn f => | |
334 | syscall' ({errVal = C_Int.fromInt ~1}, f) | |
335 | end | |
336 | end |