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