b7a30c80d412d42b2d5e8b17657dd3e014873dc3
[sbcl.git] / src / code / unix.lisp
1 ;;;; This file contains Unix support that SBCL needs to implement
2 ;;;; itself. It's derived from Peter Van Eynde's unix-glibc2.lisp for
3 ;;;; CMU CL, which was derived from CMU CL unix.lisp 1.56. But those
4 ;;;; files aspired to be complete Unix interfaces exported to the end
5 ;;;; user, while this file aims to be as simple as possible and is not
6 ;;;; intended for the end user.
7 ;;;;
8 ;;;; FIXME: The old CMU CL unix.lisp code was implemented as hand
9 ;;;; transcriptions from Unix headers into Lisp. It appears that this was as
10 ;;;; unmaintainable in practice as you'd expect in theory, so I really really
11 ;;;; don't want to do that. It'd be good to implement the various system calls
12 ;;;; as C code implemented using the Unix header files, and have their
13 ;;;; interface back to SBCL code be characterized by things like "32-bit-wide
14 ;;;; int" which are already in the interface between the runtime
15 ;;;; executable and the SBCL lisp code.
16
17 ;;;; This software is part of the SBCL system. See the README file for
18 ;;;; more information.
19 ;;;;
20 ;;;; This software is derived from the CMU CL system, which was
21 ;;;; written at Carnegie Mellon University and released into the
22 ;;;; public domain. The software is in the public domain and is
23 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
24 ;;;; files for more information.
25
26 (in-package "SB!UNIX")
27
28 (/show0 "unix.lisp 21")
29
30 ;;; Given a C-level zero-terminated array of C strings, return a
31 ;;; corresponding Lisp-level list of SIMPLE-STRINGs.
32 (defun c-strings->string-list (c-strings)
33   (declare (type (alien (* c-string)) c-strings))
34   (let ((reversed-result nil))
35     (dotimes (i most-positive-fixnum (error "argh! can't happen"))
36       (declare (type index i))
37       (let ((c-string (deref c-strings i)))
38         (if c-string
39             (push c-string reversed-result)
40             (return (nreverse reversed-result)))))))
41 \f
42 ;;;; Lisp types used by syscalls
43
44 (deftype unix-pathname () 'simple-string)
45 (deftype unix-fd () `(integer 0 ,sb!xc:most-positive-fixnum))
46
47 (deftype unix-file-mode () '(unsigned-byte 32))
48 (deftype unix-pid () '(unsigned-byte 32))
49 (deftype unix-uid () '(unsigned-byte 32))
50 (deftype unix-gid () '(unsigned-byte 32))
51 \f
52 ;;;; system calls
53
54 (/show0 "unix.lisp 74")
55
56 ;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other
57 ;;; macros in this file, are only used in this file, and could be
58 ;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN.
59 ;;;
60 ;;; SB-EXECUTABLE, at least, uses one of these macros; other libraries
61 ;;; and programs have been known to use them as well.  Perhaps they
62 ;;; should live in SB-SYS or even SB-EXT?
63
64 (defmacro syscall ((name &rest arg-types) success-form &rest args)
65   (when (eql 3 (mismatch "[_]" name))
66     (setf name
67           (concatenate 'string #!+win32 "_" (subseq name 3))))
68   `(locally
69     (declare (optimize (sb!c::float-accuracy 0)))
70     (let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
71                                 ,@args)))
72       (if (minusp result)
73           (values nil (get-errno))
74           ,success-form))))
75
76 ;;; This is like SYSCALL, but if it fails, signal an error instead of
77 ;;; returning error codes. Should only be used for syscalls that will
78 ;;; never really get an error.
79 (defmacro syscall* ((name &rest arg-types) success-form &rest args)
80   `(locally
81     (declare (optimize (sb!c::float-accuracy 0)))
82     (let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
83                                  ,@args)))
84       (if (minusp result)
85           (error "Syscall ~A failed: ~A" ,name (strerror))
86           ,success-form))))
87
88 (defmacro int-syscall ((name &rest arg-types) &rest args)
89   `(syscall (,name ,@arg-types) (values result 0) ,@args))
90
91 (defmacro with-restarted-syscall ((&optional (value (gensym))
92                                              (errno (gensym)))
93                                   syscall-form &rest body)
94   #!+sb-doc
95   "Evaluate BODY with VALUE and ERRNO bound to the return values of
96 SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted."
97   `(let (,value ,errno)
98      (loop (multiple-value-setq (,value ,errno)
99              ,syscall-form)
100         (unless #!-win32 (eql ,errno sb!unix:eintr) #!+win32 nil
101           (return (values ,value ,errno))))
102      ,@body))
103
104 (defmacro void-syscall ((name &rest arg-types) &rest args)
105   `(syscall (,name ,@arg-types) (values t 0) ,@args))
106
107 #!+win32
108 (progn
109   (defconstant espipe 29))
110 \f
111 ;;;; hacking the Unix environment
112
113 #!-win32
114 (define-alien-routine ("getenv" posix-getenv) c-string
115   "Return the \"value\" part of the environment string \"name=value\" which
116 corresponds to NAME, or NIL if there is none."
117   (name (c-string :not-null t)))
118 \f
119 ;;; from stdio.h
120
121 ;;; Rename the file with string NAME1 to the string NAME2. NIL and an
122 ;;; error code is returned if an error occurs.
123 #!-win32
124 (defun unix-rename (name1 name2)
125   (declare (type unix-pathname name1 name2))
126   (void-syscall ("rename" (c-string :not-null t)
127                           (c-string :not-null t))
128                 name1 name2))
129 \f
130 ;;; from sys/types.h and gnu/types.h
131
132 (/show0 "unix.lisp 220")
133
134 ;;; FIXME: We shouldn't hand-copy types from header files into Lisp
135 ;;; like this unless we have extreme provocation. Reading directories
136 ;;; is not extreme enough, since it doesn't need to be blindingly
137 ;;; fast: we can just implement those functions in C as a wrapper
138 ;;; layer.
139 (define-alien-type fd-mask unsigned)
140
141 (define-alien-type nil
142   (struct fd-set
143           (fds-bits (array fd-mask #.(/ fd-setsize
144                                         sb!vm:n-machine-word-bits)))))
145
146 (/show0 "unix.lisp 304")
147 \f
148 \f
149 ;;;; fcntl.h
150 ;;;;
151 ;;;; POSIX Standard: 6.5 File Control Operations        <fcntl.h>
152
153 ;;; Open the file whose pathname is specified by PATH for reading
154 ;;; and/or writing as specified by the FLAGS argument. Various FLAGS
155 ;;; masks (O_RDONLY etc.) are defined in fcntlbits.h.
156 ;;;
157 ;;; If the O_CREAT flag is specified, then the file is created with a
158 ;;; permission of argument MODE if the file doesn't exist. An integer
159 ;;; file descriptor is returned by UNIX-OPEN.
160 (defun unix-open (path flags mode)
161   (declare (type unix-pathname path)
162            (type fixnum flags)
163            (type unix-file-mode mode))
164   #!+win32 (sb!win32:unixlike-open path flags mode)
165   #!-win32
166   (with-restarted-syscall (value errno)
167     (int-syscall ("open" c-string int int)
168                  path
169                  (logior #!+win32 o_binary
170                          #!+largefile o_largefile
171                          flags)
172                  mode)))
173
174 ;;; UNIX-CLOSE accepts a file descriptor and attempts to close the file
175 ;;; associated with it.
176 (/show0 "unix.lisp 391")
177 (defun unix-close (fd)
178   #!+win32 (sb!win32:unixlike-close fd)
179   #!-win32 (declare (type unix-fd fd))
180   #!-win32 (void-syscall ("close" int) fd))
181 \f
182 ;;;; stdlib.h
183
184 ;;; There are good reasons to implement some OPEN options with an
185 ;;; mkstemp(3)-like routine, but we don't do that yet.  Instead, this
186 ;;; function is used only to make a temporary file for RUN-PROGRAM.
187 ;;; sb_mkstemp() is a wrapper that lives in src/runtime/wrap.c.  Since
188 ;;; SUSv3 mkstemp() doesn't specify the mode of the created file and
189 ;;; since we have to implement most of this ourselves for Windows
190 ;;; anyway, it seems worthwhile to depart from the mkstemp()
191 ;;; specification by taking a mode to use when creating the new file.
192 (defun sb-mkstemp (template-string mode)
193   (declare (type string template-string)
194            (type unix-file-mode mode))
195   (let ((template-buffer (string-to-octets template-string :null-terminate t)))
196     (with-pinned-objects (template-buffer)
197       (let ((fd (alien-funcall (extern-alien "sb_mkstemp"
198                                              (function int (* char) int))
199                                (vector-sap template-buffer)
200                                mode)))
201         (if (minusp fd)
202             (values nil (get-errno))
203             (values #!-win32 fd #!+win32 (sb!win32::duplicate-and-unwrap-fd fd)
204                     (octets-to-string template-buffer)))))))
205 \f
206 ;;;; timebits.h
207
208 ;; A time value that is accurate to the nearest
209 ;; microsecond but also has a range of years.
210 ;; CLH: Note that tv-usec used to be a time-t, but that this seems
211 ;; problematic on Darwin x86-64 (and wrong). Trying suseconds-t.
212 #!-(or win32 openbsd netbsd)
213 (define-alien-type nil
214   (struct timeval
215           (tv-sec time-t)           ; seconds
216           (tv-usec suseconds-t)))   ; and microseconds
217
218 ;; The above definition doesn't work on 64-bit OpenBSD platforms.
219 ;; Both tv_sec and tv_usec are declared as long instead of time_t, and
220 ;; time_t is a typedef for int.
221 #!+(or openbsd netbsd)
222 (define-alien-type nil
223   (struct timeval
224           (tv-sec long)             ; seconds
225           (tv-usec long)))          ; and microseconds
226
227 #!+win32
228 (define-alien-type nil
229   (struct timeval
230           (tv-sec time-t)           ; seconds
231           (tv-usec long)))          ; and microseconds
232 \f
233 ;;;; resourcebits.h
234
235 (defconstant rusage_self 0) ; the calling process
236 (defconstant rusage_children -1) ; terminated child processes
237 (defconstant rusage_both -2)
238
239 (define-alien-type nil
240   (struct rusage
241     (ru-utime (struct timeval))     ; user time used
242     (ru-stime (struct timeval))     ; system time used.
243     (ru-maxrss long)                ; maximum resident set size (in kilobytes)
244     (ru-ixrss long)                 ; integral shared memory size
245     (ru-idrss long)                 ; integral unshared data size
246     (ru-isrss long)                 ; integral unshared stack size
247     (ru-minflt long)                ; page reclaims
248     (ru-majflt long)                ; page faults
249     (ru-nswap long)                 ; swaps
250     (ru-inblock long)               ; block input operations
251     (ru-oublock long)               ; block output operations
252     (ru-msgsnd long)                ; messages sent
253     (ru-msgrcv long)                ; messages received
254     (ru-nsignals long)              ; signals received
255     (ru-nvcsw long)                 ; voluntary context switches
256     (ru-nivcsw long)))              ; involuntary context switches
257 \f
258 ;;;; unistd.h
259
260 ;;; Given a file path (a string) and one of four constant modes,
261 ;;; return T if the file is accessible with that mode and NIL if not.
262 ;;; When NIL, also return an errno value with NIL which tells why the
263 ;;; file was not accessible.
264 ;;;
265 ;;; The access modes are:
266 ;;;   r_ok     Read permission.
267 ;;;   w_ok     Write permission.
268 ;;;   x_ok     Execute permission.
269 ;;;   f_ok     Presence of file.
270
271 ;;; In Windows, the MODE argument to access is defined in terms of
272 ;;; literal magic numbers---there are no constants to grovel.  X_OK
273 ;;; is not defined.
274 #!+win32
275 (progn
276   (defconstant f_ok 0)
277   (defconstant w_ok 2)
278   (defconstant r_ok 4))
279
280 (defun unix-access (path mode)
281   (declare (type unix-pathname path)
282            (type (mod 8) mode))
283   (void-syscall ("[_]access" c-string int) path mode))
284
285 ;;; values for the second argument to UNIX-LSEEK
286 ;;; Note that nowadays these are called SEEK_SET, SEEK_CUR, and SEEK_END
287 (defconstant l_set 0) ; to set the file pointer
288 (defconstant l_incr 1) ; to increment the file pointer
289 (defconstant l_xtnd 2) ; to extend the file size
290
291 ;; off_t is 32 bit on Windows, yet our functions support 64 bit seeks.
292 (define-alien-type unix-offset
293   #!-win32 off-t
294   #!+win32 (signed 64))
295
296 ;;; Is a stream interactive?
297 (defun unix-isatty (fd)
298   (declare (type unix-fd fd))
299   #!-win32 (int-syscall ("isatty" int) fd)
300   #!+win32 (sb!win32::windows-isatty fd))
301
302 (defun unix-lseek (fd offset whence)
303   "Unix-lseek accepts a file descriptor and moves the file pointer by
304    OFFSET octets.  Whence can be any of the following:
305
306    L_SET        Set the file pointer.
307    L_INCR       Increment the file pointer.
308    L_XTND       Extend the file size.
309   "
310   (declare (type unix-fd fd)
311            (type (integer 0 2) whence))
312   (let ((result
313          #!-win32
314           (alien-funcall (extern-alien #!-largefile "lseek"
315                                              #!+largefile "lseek_largefile"
316                                              (function off-t int off-t int))
317                         fd offset whence)
318           #!+win32 (sb!win32:lseeki64 fd offset whence)))
319     (if (minusp result)
320         (values nil (get-errno))
321       (values result 0))))
322
323 ;;; UNIX-READ accepts a file descriptor, a buffer, and the length to read.
324 ;;; It attempts to read len bytes from the device associated with fd
325 ;;; and store them into the buffer. It returns the actual number of
326 ;;; bytes read.
327
328 #!-sb!fluid
329 (declaim (maybe-inline unix-read))
330
331 (defun unix-read (fd buf len)
332   (declare (type unix-fd fd)
333            (type (unsigned-byte 32) len))
334   (int-syscall (#!-win32 "read" #!+win32 "win32_unix_read"
335                 int (* char) int) fd buf len))
336
337 ;;; UNIX-WRITE accepts a file descriptor, a buffer, an offset, and the
338 ;;; length to write. It attempts to write len bytes to the device
339 ;;; associated with fd from the buffer starting at offset. It returns
340 ;;; the actual number of bytes written.
341 (defun unix-write (fd buf offset len)
342   (declare (type unix-fd fd)
343            (type (unsigned-byte 32) offset len))
344   (flet ((%write (sap)
345            (declare (system-area-pointer sap))
346            (int-syscall (#!-win32 "write" #!+win32 "win32_unix_write"
347                          int (* char) int)
348                         fd
349                         (with-alien ((ptr (* char) sap))
350                           (addr (deref ptr offset)))
351                         len)))
352     (etypecase buf
353       ((simple-array * (*))
354        (with-pinned-objects (buf)
355          (%write (vector-sap buf))))
356       (system-area-pointer
357        (%write buf)))))
358
359 ;;; Set up a unix-piping mechanism consisting of an input pipe and an
360 ;;; output pipe. Return two values: if no error occurred the first
361 ;;; value is the pipe to be read from and the second is can be written
362 ;;; to. If an error occurred the first value is NIL and the second the
363 ;;; unix error code.
364 #!-win32
365 (defun unix-pipe ()
366   (with-alien ((fds (array int 2)))
367     (syscall ("pipe" (* int))
368              (values (deref fds 0) (deref fds 1))
369              (cast fds (* int)))))
370
371 #!+win32
372 (defun unix-pipe ()
373   (sb!win32::windows-pipe))
374
375 ;; Windows mkdir() doesn't take the mode argument. It's cdecl, so we could
376 ;; actually call it passing the mode argument, but some sharp-eyed reader
377 ;; would put five and twenty-seven together and ask us about it, so...
378 ;;    -- AB, 2005-12-27
379 #!-win32
380 (defun unix-mkdir (name mode)
381   (declare (type unix-pathname name)
382            (type unix-file-mode mode)
383            #!+win32 (ignore mode))
384   (void-syscall ("mkdir" c-string #!-win32 int) name #!-win32 mode))
385
386 ;;; Given a C char* pointer allocated by malloc(), free it and return a
387 ;;; corresponding Lisp string (or return NIL if the pointer is a C NULL).
388 (defun newcharstar-string (newcharstar)
389   (declare (type (alien (* char)) newcharstar))
390   (if (null-alien newcharstar)
391       nil
392       (prog1
393           (cast newcharstar c-string)
394         (free-alien newcharstar))))
395
396 ;;; Return the Unix current directory as a SIMPLE-STRING, in the
397 ;;; style returned by getcwd() (no trailing slash character).
398 #!-win32
399 (defun posix-getcwd ()
400   ;; This implementation relies on a BSD/Linux extension to getcwd()
401   ;; behavior, automatically allocating memory when a null buffer
402   ;; pointer is used. On a system which doesn't support that
403   ;; extension, it'll have to be rewritten somehow.
404   ;;
405   ;; SunOS and OSF/1 provide almost as useful an extension: if given a null
406   ;; buffer pointer, it will automatically allocate size space. The
407   ;; KLUDGE in this solution arises because we have just read off
408   ;; PATH_MAX+1 from the Solaris header files and stuck it in here as
409   ;; a constant. Going the grovel_headers route doesn't seem to be
410   ;; helpful, either, as Solaris doesn't export PATH_MAX from
411   ;; unistd.h.
412   ;;
413   ;; Signal an error at compile-time, since it's needed for the
414   ;; runtime to start up
415   #!-(or linux openbsd freebsd netbsd sunos osf1 darwin hpux win32)
416   #.(error "POSIX-GETCWD is not implemented.")
417   #!+(or linux openbsd freebsd netbsd sunos osf1 darwin hpux win32)
418   (or (newcharstar-string (alien-funcall (extern-alien "getcwd"
419                                                        (function (* char)
420                                                                  (* char)
421                                                                  size-t))
422                                          nil
423                                          #!+(or linux openbsd freebsd netbsd darwin win32) 0
424                                          #!+(or sunos osf1 hpux) 1025))
425       (simple-perror "getcwd")))
426
427 ;;; Return the Unix current directory as a SIMPLE-STRING terminated
428 ;;; by a slash character.
429 (defun posix-getcwd/ ()
430   (concatenate 'string (posix-getcwd) "/"))
431
432 ;;; Duplicate an existing file descriptor (given as the argument) and
433 ;;; return it. If FD is not a valid file descriptor, NIL and an error
434 ;;; number are returned.
435 #!-win32
436 (defun unix-dup (fd)
437   (declare (type unix-fd fd))
438   (int-syscall ("dup" int) fd))
439
440 ;;; Terminate the current process with an optional error code. If
441 ;;; successful, the call doesn't return. If unsuccessful, the call
442 ;;; returns NIL and an error number.
443 (deftype exit-code ()
444   `(signed-byte 32))
445 (defun os-exit (code &key abort)
446   #!+sb-doc
447   "Exit the process with CODE. If ABORT is true, exit is performed using _exit(2),
448 avoiding atexit(3) hooks, etc. Otherwise exit(2) is called."
449   (unless (typep code 'exit-code)
450     (setf code (if abort 1 0)))
451   (if abort
452       (void-syscall ("_exit" int) code)
453       (void-syscall ("exit" int) code)))
454
455 (define-deprecated-function :early "1.0.56.55" unix-exit os-exit (code)
456   (os-exit code))
457
458 ;;; Return the process id of the current process.
459 (define-alien-routine (#!+win32 "_getpid" #!-win32 "getpid" unix-getpid) int)
460
461 ;;; Return the real user id associated with the current process.
462 #!-win32
463 (define-alien-routine ("getuid" unix-getuid) int)
464
465 ;;; Translate a user id into a login name.
466 #!-win32
467 (defun uid-username (uid)
468   (or (newcharstar-string (alien-funcall (extern-alien "uid_username"
469                                                        (function (* char) int))
470                                          uid))
471       (error "found no match for Unix uid=~S" uid)))
472
473 ;;; Return the namestring of the home directory, being careful to
474 ;;; include a trailing #\/
475 #!-win32
476 (progn
477   (defun uid-homedir (uid)
478     (or (newcharstar-string (alien-funcall (extern-alien "uid_homedir"
479                                                          (function (* char) int))
480                                            uid))
481         (error "failed to resolve home directory for Unix uid=~S" uid)))
482
483   (defun user-homedir (uid)
484     (or (newcharstar-string (alien-funcall (extern-alien "user_homedir"
485                                                          (function (* char) c-string))
486                                            uid))
487         (error "failed to resolve home directory for Unix uid=~S" uid))))
488
489 ;;; Invoke readlink(2) on the file name specified by PATH. Return
490 ;;; (VALUES LINKSTRING NIL) on success, or (VALUES NIL ERRNO) on
491 ;;; failure.
492 #!-win32
493 (defun unix-readlink (path)
494   (declare (type unix-pathname path))
495   (with-alien ((ptr (* char)
496                     (alien-funcall (extern-alien
497                                     "wrapped_readlink"
498                                     (function (* char) c-string))
499                                    path)))
500     (if (null-alien ptr)
501         (values nil (get-errno))
502         (multiple-value-prog1
503             (values (with-alien ((c-string c-string ptr)) c-string)
504                     nil)
505           (free-alien ptr)))))
506 #!+win32
507 ;; Win32 doesn't do links, but something likes to call this anyway.
508 ;; Something in this file, no less. But it only takes one result, so...
509 (defun unix-readlink (path)
510   (declare (ignore path))
511   nil)
512
513 (defun unix-realpath (path)
514   (declare (type unix-pathname path))
515   (with-alien ((ptr (* char)
516                     (alien-funcall (extern-alien
517                                     "sb_realpath"
518                                     (function (* char) c-string))
519                                    path)))
520     (if (null-alien ptr)
521         (values nil (get-errno))
522         (multiple-value-prog1
523             (values (with-alien ((c-string c-string ptr)) c-string)
524                     nil)
525           (free-alien ptr)))))
526
527 ;;; UNIX-UNLINK accepts a name and deletes the directory entry for that
528 ;;; name and the file if this is the last link.
529 (defun unix-unlink (name)
530   (declare (type unix-pathname name))
531   (void-syscall ("[_]unlink" c-string) name))
532
533 ;;; Return the name of the host machine as a string.
534 #!-win32
535 (defun unix-gethostname ()
536   (with-alien ((buf (array char 256)))
537     (syscall ("gethostname" (* char) int)
538              (cast buf c-string)
539              (cast buf (* char)) 256)))
540
541 #!-win32
542 (defun unix-setsid ()
543   (int-syscall ("setsid")))
544
545 ;;;; sys/ioctl.h
546
547 ;;; UNIX-IOCTL performs a variety of operations on open i/o
548 ;;; descriptors. See the UNIX Programmer's Manual for more
549 ;;; information.
550 #!-win32
551 (defun unix-ioctl (fd cmd arg)
552   (declare (type unix-fd fd)
553            (type (signed-byte 32) cmd))
554   (void-syscall ("ioctl" int int (* char)) fd cmd arg))
555 \f
556 ;;;; sys/resource.h
557
558 ;;; FIXME: All we seem to need is the RUSAGE_SELF version of this.
559 ;;;
560 ;;; This is like getrusage(2), except it returns only the system and
561 ;;; user time, and returns the seconds and microseconds as separate
562 ;;; values.
563 #!-sb-fluid (declaim (inline unix-fast-getrusage))
564 #!-win32
565 (defun unix-fast-getrusage (who)
566   (declare (values (member t)
567                    (unsigned-byte 31) (integer 0 1000000)
568                    (unsigned-byte 31) (integer 0 1000000)))
569   (with-alien ((usage (struct rusage)))
570     (syscall* ("getrusage" int (* (struct rusage)))
571               (values t
572                       (slot (slot usage 'ru-utime) 'tv-sec)
573                       (slot (slot usage 'ru-utime) 'tv-usec)
574                       (slot (slot usage 'ru-stime) 'tv-sec)
575                       (slot (slot usage 'ru-stime) 'tv-usec))
576               who (addr usage))))
577
578 ;;; Return information about the resource usage of the process
579 ;;; specified by WHO. WHO can be either the current process
580 ;;; (rusage_self) or all of the terminated child processes
581 ;;; (rusage_children). NIL and an error number is returned if the call
582 ;;; fails.
583 #!-win32
584 (defun unix-getrusage (who)
585   (with-alien ((usage (struct rusage)))
586     (syscall ("getrusage" int (* (struct rusage)))
587               (values t
588                       (+ (* (slot (slot usage 'ru-utime) 'tv-sec) 1000000)
589                          (slot (slot usage 'ru-utime) 'tv-usec))
590                       (+ (* (slot (slot usage 'ru-stime) 'tv-sec) 1000000)
591                          (slot (slot usage 'ru-stime) 'tv-usec))
592                       (slot usage 'ru-maxrss)
593                       (slot usage 'ru-ixrss)
594                       (slot usage 'ru-idrss)
595                       (slot usage 'ru-isrss)
596                       (slot usage 'ru-minflt)
597                       (slot usage 'ru-majflt)
598                       (slot usage 'ru-nswap)
599                       (slot usage 'ru-inblock)
600                       (slot usage 'ru-oublock)
601                       (slot usage 'ru-msgsnd)
602                       (slot usage 'ru-msgrcv)
603                       (slot usage 'ru-nsignals)
604                       (slot usage 'ru-nvcsw)
605                       (slot usage 'ru-nivcsw))
606               who (addr usage))))
607 \f
608 (defvar *on-dangerous-wait* :warn)
609
610 ;;; Calling select in a bad place can hang in a nasty manner, so it's better
611 ;;; to have some way to detect these.
612 (defun note-dangerous-wait (type)
613   (let ((action *on-dangerous-wait*)
614         (*on-dangerous-wait* nil))
615     (case action
616       (:warn
617        (warn "Starting a ~A without a timeout while interrupts are ~
618              disabled."
619              type))
620       (:error
621        (error "Starting a ~A without a timeout while interrupts are ~
622               disabled."
623               type))
624       (:backtrace
625        (format *debug-io*
626                "~&=== Starting a ~A without a timeout while interrupts are disabled. ===~%"
627                type)
628        (sb!debug:backtrace)))
629     nil))
630 \f
631 ;;;; poll.h
632 #!+os-provides-poll
633 (progn
634   (define-alien-type nil
635       (struct pollfd
636               (fd      int)
637               (events  short)           ; requested events
638               (revents short)))         ; returned events
639
640   (defun unix-simple-poll (fd direction to-msec)
641     (declare (fixnum fd to-msec))
642     (when (and (minusp to-msec) (not *interrupts-enabled*))
643       (note-dangerous-wait "poll(2)"))
644     (let ((events (ecase direction
645                     (:input (logior pollin pollpri))
646                     (:output pollout))))
647       (with-alien ((fds (struct pollfd)))
648         (with-restarted-syscall (count errno)
649           (progn
650             (setf (slot fds 'fd) fd
651                   (slot fds 'events) events
652                   (slot fds 'revents) 0)
653             (int-syscall ("poll" (* (struct pollfd)) int int)
654                          (addr fds) 1 to-msec))
655           (if (zerop errno)
656               (let ((revents (slot fds 'revents)))
657                 (or (and (eql 1 count) (logtest events revents))
658                     (logtest pollhup revents)))
659               (error "Syscall poll(2) failed: ~A" (strerror))))))))
660 \f
661 ;;;; sys/select.h
662
663 (defmacro with-fd-setsize ((n) &body body)
664   `(let ((,n (if (< 0 ,n fd-setsize)
665                  ,n
666                  (error "Cannot select(2) on ~D: above FD_SETSIZE limit."
667                         (1- num-descriptors)))))
668      (declare (type (integer 0 #.fd-setsize) ,n))
669      ,@body))
670
671 ;;;; FIXME: Why have both UNIX-SELECT and UNIX-FAST-SELECT?
672
673 ;;; Perform the UNIX select(2) system call.
674 (declaim (inline unix-fast-select))
675 (defun unix-fast-select (num-descriptors
676                          read-fds write-fds exception-fds
677                          timeout-secs timeout-usecs)
678   (declare (type integer num-descriptors)
679            (type (or (alien (* (struct fd-set))) null)
680                  read-fds write-fds exception-fds)
681            (type (or null (unsigned-byte 31)) timeout-secs timeout-usecs))
682   (with-fd-setsize (num-descriptors)
683     (flet ((select (tv-sap)
684              (int-syscall ("select" int (* (struct fd-set)) (* (struct fd-set))
685                                     (* (struct fd-set)) (* (struct timeval)))
686                           num-descriptors read-fds write-fds exception-fds
687                           tv-sap)))
688       (cond ((or timeout-secs timeout-usecs)
689              (with-alien ((tv (struct timeval)))
690                (setf (slot tv 'tv-sec) (or timeout-secs 0))
691                (setf (slot tv 'tv-usec) (or timeout-usecs 0))
692                (select (alien-sap (addr tv)))))
693             (t
694              (unless *interrupts-enabled*
695                (note-dangerous-wait "select(2)"))
696              (select (int-sap 0)))))))
697
698 ;;; UNIX-SELECT accepts sets of file descriptors and waits for an event
699 ;;; to happen on one of them or to time out.
700 (defmacro num-to-fd-set (fdset num)
701   `(if (fixnump ,num)
702        (progn
703          (setf (deref (slot ,fdset 'fds-bits) 0) ,num)
704          ,@(loop for index upfrom 1 below (/ fd-setsize
705                                              sb!vm:n-machine-word-bits)
706              collect `(setf (deref (slot ,fdset 'fds-bits) ,index) 0)))
707        (progn
708          ,@(loop for index upfrom 0 below (/ fd-setsize
709                                              sb!vm:n-machine-word-bits)
710              collect `(setf (deref (slot ,fdset 'fds-bits) ,index)
711                             (ldb (byte sb!vm:n-machine-word-bits
712                                        ,(* index sb!vm:n-machine-word-bits))
713                                  ,num))))))
714
715 (defmacro fd-set-to-num (nfds fdset)
716   `(if (<= ,nfds sb!vm:n-machine-word-bits)
717        (deref (slot ,fdset 'fds-bits) 0)
718        (+ ,@(loop for index upfrom 0 below (/ fd-setsize
719                                               sb!vm:n-machine-word-bits)
720               collect `(ash (deref (slot ,fdset 'fds-bits) ,index)
721                             ,(* index sb!vm:n-machine-word-bits))))))
722
723 ;;; Examine the sets of descriptors passed as arguments to see whether
724 ;;; they are ready for reading and writing. See the UNIX Programmer's
725 ;;; Manual for more information.
726 (defun unix-select (nfds rdfds wrfds xpfds to-secs &optional (to-usecs 0))
727   (declare (type integer nfds)
728            (type unsigned-byte rdfds wrfds xpfds)
729            (type (or (unsigned-byte 31) null) to-secs)
730            (type (unsigned-byte 31) to-usecs)
731            (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
732   (with-fd-setsize (nfds)
733     (with-alien ((tv (struct timeval))
734                  (rdf (struct fd-set))
735                  (wrf (struct fd-set))
736                  (xpf (struct fd-set)))
737       (cond (to-secs
738              (setf (slot tv 'tv-sec) to-secs
739                    (slot tv 'tv-usec) to-usecs))
740             ((not *interrupts-enabled*)
741              (note-dangerous-wait "select(2)")))
742       (num-to-fd-set rdf rdfds)
743       (num-to-fd-set wrf wrfds)
744       (num-to-fd-set xpf xpfds)
745       (macrolet ((frob (lispvar alienvar)
746                    `(if (zerop ,lispvar)
747                         (int-sap 0)
748                         (alien-sap (addr ,alienvar)))))
749         (syscall ("select" int (* (struct fd-set)) (* (struct fd-set))
750                            (* (struct fd-set)) (* (struct timeval)))
751                  (values result
752                          (fd-set-to-num nfds rdf)
753                          (fd-set-to-num nfds wrf)
754                          (fd-set-to-num nfds xpf))
755                  nfds (frob rdfds rdf) (frob wrfds wrf) (frob xpfds xpf)
756                  (if to-secs (alien-sap (addr tv)) (int-sap 0)))))))
757
758 ;;; Lisp-side implmentations of FD_FOO macros. Abandon all hope who enters
759 ;;; here...
760 ;;;
761 (defmacro fd-set (offset fd-set)
762   (with-unique-names (word bit)
763     `(multiple-value-bind (,word ,bit) (floor ,offset
764                                               sb!vm:n-machine-word-bits)
765        (setf (deref (slot ,fd-set 'fds-bits) ,word)
766              (logior (truly-the (unsigned-byte #.sb!vm:n-machine-word-bits)
767                                 (ash 1 ,bit))
768                      (deref (slot ,fd-set 'fds-bits) ,word))))))
769
770 (defmacro fd-clr (offset fd-set)
771   (with-unique-names (word bit)
772     `(multiple-value-bind (,word ,bit) (floor ,offset
773                                               sb!vm:n-machine-word-bits)
774        (setf (deref (slot ,fd-set 'fds-bits) ,word)
775              (logand (deref (slot ,fd-set 'fds-bits) ,word)
776                      (sb!kernel:word-logical-not
777                       (truly-the (unsigned-byte #.sb!vm:n-machine-word-bits)
778                                  (ash 1 ,bit))))))))
779
780 (defmacro fd-isset (offset fd-set)
781   (with-unique-names (word bit)
782     `(multiple-value-bind (,word ,bit) (floor ,offset
783                                               sb!vm:n-machine-word-bits)
784        (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word)))))
785
786 (defmacro fd-zero (fd-set)
787   `(progn
788      ,@(loop for index upfrom 0 below (/ fd-setsize sb!vm:n-machine-word-bits)
789          collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0))))
790
791 #!-os-provides-poll
792 (defun unix-simple-poll (fd direction to-msec)
793   (multiple-value-bind (to-sec to-usec)
794       (if (minusp to-msec)
795           (values nil nil)
796           (multiple-value-bind (to-sec to-msec2) (truncate to-msec 1000)
797             (values to-sec (* to-msec2 1000))))
798     (sb!unix:with-restarted-syscall (count errno)
799       (sb!alien:with-alien ((fds (sb!alien:struct sb!unix:fd-set)))
800         (sb!unix:fd-zero fds)
801         (sb!unix:fd-set fd fds)
802         (multiple-value-bind (read-fds write-fds)
803             (ecase direction
804               (:input
805                (values (addr fds) nil))
806               (:output
807                (values nil (addr fds))))
808           (sb!unix:unix-fast-select (1+ fd)
809                                     read-fds write-fds nil
810                                     to-sec to-usec)))
811       (case count
812         ((1) t)
813         ((0) nil)
814         (otherwise
815          (error "Syscall select(2) failed on fd ~D: ~A" fd (strerror)))))))
816 \f
817 ;;;; sys/stat.h
818
819 ;;; This is a structure defined in src/runtime/wrap.c, to look
820 ;;; basically like "struct stat" according to stat(2). It may not
821 ;;; actually correspond to the real in-memory stat structure that the
822 ;;; syscall uses, and that's OK. Linux in particular is packed full of
823 ;;; stat macros, and trying to keep Lisp code in correspondence with
824 ;;; it is more pain than it's worth, so we just let our C runtime
825 ;;; synthesize a nice consistent structure for us.
826 ;;;
827 ;;; Note that st-dev is a long, not a dev-t. This is because dev-t on
828 ;;; linux 32 bit archs is a 64 bit quantity, but alien doesn't support
829 ;;; those. We don't actually access that field anywhere, though, so
830 ;;; until we can get 64 bit alien support it'll do. Also note that
831 ;;; st_size is a long, not an off-t, because off-t is a 64-bit
832 ;;; quantity on Alpha. And FIXME: "No one would want a file length
833 ;;; longer than 32 bits anyway, right?":-|
834 ;;;
835 ;;; The comment about alien and 64-bit quantities has not been kept in
836 ;;; sync with the comment now in wrap.h (formerly wrap.c), but it's
837 ;;; not clear whether either comment is correct.  -- RMK 2007-11-14.
838 (define-alien-type nil
839   (struct wrapped_stat
840     (st-dev wst-dev-t)
841     (st-ino ino-t)
842     (st-mode mode-t)
843     (st-nlink wst-nlink-t)
844     (st-uid wst-uid-t)
845     (st-gid wst-gid-t)
846     (st-rdev wst-dev-t)
847     (st-size wst-off-t)
848     (st-blksize wst-blksize-t)
849     (st-blocks wst-blkcnt-t)
850     (st-atime time-t)
851     (st-mtime time-t)
852     (st-ctime time-t)))
853
854 ;;; shared C-struct-to-multiple-VALUES conversion for the stat(2)
855 ;;; family of Unix system calls
856 ;;;
857 ;;; FIXME: I think this should probably not be INLINE. However, when
858 ;;; this was not inline, it seemed to cause memory corruption
859 ;;; problems. My first guess is that it's a bug in the FFI code, where
860 ;;; the WITH-ALIEN expansion doesn't deal well with being wrapped
861 ;;; around a call to a function returning >10 values. But I didn't try
862 ;;; to figure it out, just inlined it as a quick fix. Perhaps someone
863 ;;; who's motivated to debug the FFI code can go over the DISASSEMBLE
864 ;;; output in the not-inlined case and see whether there's a problem,
865 ;;; and maybe even find a fix..
866 (declaim (inline %extract-stat-results))
867 (defun %extract-stat-results (wrapped-stat)
868   (declare (type (alien (* (struct wrapped_stat))) wrapped-stat))
869   (values t
870           (slot wrapped-stat 'st-dev)
871           (slot wrapped-stat 'st-ino)
872           (slot wrapped-stat 'st-mode)
873           (slot wrapped-stat 'st-nlink)
874           (slot wrapped-stat 'st-uid)
875           (slot wrapped-stat 'st-gid)
876           (slot wrapped-stat 'st-rdev)
877           (slot wrapped-stat 'st-size)
878           (slot wrapped-stat 'st-atime)
879           (slot wrapped-stat 'st-mtime)
880           (slot wrapped-stat 'st-ctime)
881           (slot wrapped-stat 'st-blksize)
882           (slot wrapped-stat 'st-blocks)))
883
884 ;;; Unix system calls in the stat(2) family are handled by calls to
885 ;;; C-level wrapper functions which copy all the raw "struct stat"
886 ;;; slots into the system-independent wrapped_stat format.
887 ;;;    stat(2) <->  stat_wrapper()
888 ;;;   fstat(2) <-> fstat_wrapper()
889 ;;;   lstat(2) <-> lstat_wrapper()
890 (defun unix-stat (name)
891   (declare (type unix-pathname name))
892   (with-alien ((buf (struct wrapped_stat)))
893     (syscall ("stat_wrapper" c-string (* (struct wrapped_stat)))
894              (%extract-stat-results (addr buf))
895              name (addr buf))))
896 (defun unix-lstat (name)
897   (declare (type unix-pathname name))
898   (with-alien ((buf (struct wrapped_stat)))
899     (syscall ("lstat_wrapper" c-string (* (struct wrapped_stat)))
900              (%extract-stat-results (addr buf))
901              name (addr buf))))
902 (defun unix-fstat (fd)
903   #!-win32
904   (declare (type unix-fd fd))
905   (#!-win32 funcall #!+win32 sb!win32::call-with-crt-fd
906    (lambda (fd)
907      (with-alien ((buf (struct wrapped_stat)))
908        (syscall ("fstat_wrapper" int (* (struct wrapped_stat)))
909                 (%extract-stat-results (addr buf))
910                 fd (addr buf))))
911    fd))
912
913 #!-win32
914 (defun fd-type (fd)
915   (declare (type unix-fd fd))
916   (let ((fmt (logand
917               sb!unix:s-ifmt
918               (or (with-alien ((buf (struct wrapped_stat)))
919                     (syscall ("fstat_wrapper" int (* (struct wrapped_stat)))
920                              (slot buf 'st-mode)
921                              fd (addr buf)))
922                   0))))
923     (cond ((logtest sb!unix:s-ififo fmt)
924            :fifo)
925           ((logtest sb!unix:s-ifchr fmt)
926            :character)
927           ((logtest sb!unix:s-ifdir fmt)
928            :directory)
929           ((logtest sb!unix:s-ifblk fmt)
930            :block)
931           ((logtest sb!unix:s-ifreg fmt)
932            :regular)
933           ((logtest sb!unix:s-ifsock fmt)
934            :socket)
935           (t
936            :unknown))))
937 \f
938 ;;;; time.h
939
940 ;; the POSIX.4 structure for a time value. This is like a "struct
941 ;; timeval" but has nanoseconds instead of microseconds.
942 #!-(or openbsd netbsd)
943 (define-alien-type nil
944     (struct timespec
945             (tv-sec long)   ; seconds
946             (tv-nsec long))) ; nanoseconds
947
948 ;; Just as with struct timeval, 64-bit OpenBSD has problems with the
949 ;; above definition.  tv_sec is declared as time_t instead of long,
950 ;; and time_t is a typedef for int.
951 #!+(or openbsd netbsd)
952 (define-alien-type nil
953     (struct timespec
954             (tv-sec time-t)  ; seconds
955             (tv-nsec long))) ; nanoseconds
956
957 ;; used by other time functions
958 (define-alien-type nil
959     (struct tm
960             (tm-sec int)   ; Seconds.   [0-60] (1 leap second)
961             (tm-min int)   ; Minutes.   [0-59]
962             (tm-hour int)  ; Hours.     [0-23]
963             (tm-mday int)  ; Day.       [1-31]
964             (tm-mon int)   ; Month.     [0-11]
965             (tm-year int)  ; Year - 1900.
966             (tm-wday int)  ; Day of week. [0-6]
967             (tm-yday int)  ; Days in year. [0-365]
968             (tm-isdst int) ; DST.       [-1/0/1]
969             (tm-gmtoff long) ;  Seconds east of UTC.
970             (tm-zone c-string))) ; Timezone abbreviation.
971
972 (define-alien-routine get-timezone sb!alien:void
973   (when time-t :in)
974   (seconds-west sb!alien:int :out)
975   (daylight-savings-p sb!alien:boolean :out))
976
977 #!-win32
978 (defun nanosleep (secs nsecs)
979   (with-alien ((req (struct timespec))
980                (rem (struct timespec)))
981     (setf (slot req 'tv-sec) secs
982           (slot req 'tv-nsec) nsecs)
983     (loop while (and (eql sb!unix:eintr
984                           (nth-value 1
985                                      (int-syscall ("nanosleep" (* (struct timespec))
986                                                                (* (struct timespec)))
987                                                   (addr req) (addr rem))))
988                      ;; KLUDGE: On Darwin, if an interrupt cases nanosleep to
989                      ;; take longer than the requested time, the call will
990                      ;; return with EINT and (unsigned)-1 seconds in the
991                      ;; remainder timespec, which would cause us to enter
992                      ;; nanosleep again for ~136 years. So, we check that the
993                      ;; remainder time is actually decreasing.
994                      ;;
995                      ;; It would be neat to do this bit of defensive
996                      ;; programming on all platforms, but unfortunately on
997                      ;; Linux, REM can be a little higher than REQ if the
998                      ;; nanosleep() call is interrupted quickly enough,
999                      ;; probably due to the request being rounded up to the
1000                      ;; nearest HZ. This would cause the sleep to return way
1001                      ;; too early.
1002                      #!+darwin
1003                      (let ((rem-sec (slot rem 'tv-sec))
1004                            (rem-nsec (slot rem 'tv-nsec)))
1005                        (when (or (> secs rem-sec)
1006                                  (and (= secs rem-sec) (>= nsecs rem-nsec)))
1007                          ;; Update for next round.
1008                          (setf secs  rem-sec
1009                                nsecs rem-nsec)
1010                          t)))
1011           do (setf (slot req 'tv-sec) (slot rem 'tv-sec)
1012                    (slot req 'tv-nsec) (slot rem 'tv-nsec)))))
1013
1014 (defun unix-get-seconds-west (secs)
1015   (multiple-value-bind (ignore seconds dst) (get-timezone secs)
1016     (declare (ignore ignore) (ignore dst))
1017     (values seconds)))
1018 \f
1019 ;;;; sys/time.h
1020
1021 ;;; Structure crudely representing a timezone. KLUDGE: This is
1022 ;;; obsolete and should never be used.
1023 (define-alien-type nil
1024   (struct timezone
1025     (tz-minuteswest int)                ; minutes west of Greenwich
1026     (tz-dsttime int)))                  ; type of dst correction
1027 \f
1028
1029 ;; Type of the second argument to `getitimer' and
1030 ;; the second and third arguments `setitimer'.
1031 (define-alien-type nil
1032   (struct itimerval
1033     (it-interval (struct timeval))      ; timer interval
1034     (it-value (struct timeval))))       ; current value
1035
1036 (defconstant itimer-real 0)
1037 (defconstant itimer-virtual 1)
1038 (defconstant itimer-prof 2)
1039
1040 #!-win32
1041 (defun unix-getitimer (which)
1042   "Unix-getitimer returns the INTERVAL and VALUE slots of one of
1043    three system timers (:real :virtual or :profile). On success,
1044    unix-getitimer returns 5 values,
1045    T, it-interval-secs, it-interval-usec, it-value-secs, it-value-usec."
1046   (declare (type (member :real :virtual :profile) which)
1047            (values t
1048                    (unsigned-byte 29) (mod 1000000)
1049                    (unsigned-byte 29) (mod 1000000)))
1050   (let ((which (ecase which
1051                  (:real itimer-real)
1052                  (:virtual itimer-virtual)
1053                  (:profile itimer-prof))))
1054     (with-alien ((itv (struct itimerval)))
1055       (syscall* ("getitimer" int (* (struct itimerval)))
1056                 (values t
1057                         (slot (slot itv 'it-interval) 'tv-sec)
1058                         (slot (slot itv 'it-interval) 'tv-usec)
1059                         (slot (slot itv 'it-value) 'tv-sec)
1060                         (slot (slot itv 'it-value) 'tv-usec))
1061                 which (alien-sap (addr itv))))))
1062
1063 #!-win32
1064 (defun unix-setitimer (which int-secs int-usec val-secs val-usec)
1065   " Unix-setitimer sets the INTERVAL and VALUE slots of one of
1066    three system timers (:real :virtual or :profile). A SIGALRM signal
1067    will be delivered VALUE <seconds+microseconds> from now. INTERVAL,
1068    when non-zero, is <seconds+microseconds> to be loaded each time
1069    the timer expires. Setting INTERVAL and VALUE to zero disables
1070    the timer. See the Unix man page for more details. On success,
1071    unix-setitimer returns the old contents of the INTERVAL and VALUE
1072    slots as in unix-getitimer."
1073   (declare (type (member :real :virtual :profile) which)
1074            (type (unsigned-byte 29) int-secs val-secs)
1075            (type (integer 0 (1000000)) int-usec val-usec)
1076            (values t
1077                    (unsigned-byte 29) (mod 1000000)
1078                    (unsigned-byte 29) (mod 1000000)))
1079   (let ((which (ecase which
1080                  (:real itimer-real)
1081                  (:virtual itimer-virtual)
1082                  (:profile itimer-prof))))
1083     (with-alien ((itvn (struct itimerval))
1084                  (itvo (struct itimerval)))
1085       (setf (slot (slot itvn 'it-interval) 'tv-sec ) int-secs
1086             (slot (slot itvn 'it-interval) 'tv-usec) int-usec
1087             (slot (slot itvn 'it-value   ) 'tv-sec ) val-secs
1088             (slot (slot itvn 'it-value   ) 'tv-usec) val-usec)
1089       (syscall* ("setitimer" int (* (struct timeval))(* (struct timeval)))
1090                 (values t
1091                         (slot (slot itvo 'it-interval) 'tv-sec)
1092                         (slot (slot itvo 'it-interval) 'tv-usec)
1093                         (slot (slot itvo 'it-value) 'tv-sec)
1094                         (slot (slot itvo 'it-value) 'tv-usec))
1095                 which (alien-sap (addr itvn))(alien-sap (addr itvo))))))
1096
1097 \f
1098 ;;; FIXME: Many Unix error code definitions were deleted from the old
1099 ;;; CMU CL source code here, but not in the exports of SB-UNIX. I
1100 ;;; (WHN) hope that someday I'll figure out an automatic way to detect
1101 ;;; unused symbols in package exports, but if I don't, there are
1102 ;;; enough of them all in one place here that they should probably be
1103 ;;; removed by hand.
1104 \f
1105 (defconstant micro-seconds-per-internal-time-unit
1106   (/ 1000000 sb!xc:internal-time-units-per-second))
1107
1108 ;;; UNIX specific code, that has been cleanly separated from the
1109 ;;; Windows build.
1110 #!-win32
1111 (progn
1112
1113   #!-sb-fluid (declaim (inline get-time-of-day))
1114   (defun get-time-of-day ()
1115     "Return the number of seconds and microseconds since the beginning of
1116 the UNIX epoch (January 1st 1970.)"
1117     #!+darwin
1118     (with-alien ((tv (struct timeval)))
1119       ;; CLH: FIXME! This seems to be a MacOS bug, but on x86-64/darwin,
1120       ;; gettimeofday occasionally fails. passing in a null pointer for the
1121       ;; timezone struct seems to work around the problem. NS notes: Darwin
1122       ;; manpage says the timezone is not used anymore in their implementation
1123       ;; at all.
1124       (syscall* ("gettimeofday" (* (struct timeval))
1125                                 (* (struct timezone)))
1126                 (values (slot tv 'tv-sec)
1127                         (slot tv 'tv-usec))
1128                 (addr tv)
1129                 nil))
1130     #!-(and x86-64 darwin)
1131     (with-alien ((tv (struct timeval))
1132                  (tz (struct timezone)))
1133       (syscall* ("gettimeofday" (* (struct timeval))
1134                                 (* (struct timezone)))
1135                 (values (slot tv 'tv-sec)
1136                         (slot tv 'tv-usec))
1137                 (addr tv)
1138                 (addr tz))))
1139
1140   (declaim (inline system-internal-run-time
1141                    system-real-time-values))
1142
1143   (defun system-real-time-values ()
1144     (multiple-value-bind (sec usec) (get-time-of-day)
1145       (declare (type (unsigned-byte 32) sec usec))
1146       (values sec (truncate usec micro-seconds-per-internal-time-unit))))
1147
1148   ;; There are two optimizations here that actually matter (on 32-bit
1149   ;; systems): substract the epoch from seconds and milliseconds
1150   ;; separately, as those should remain fixnums for the first 17 years
1151   ;; or so of runtime. Also, avoid doing consing a new bignum if the
1152   ;; result would be = to the last result given.
1153   ;;
1154   ;; Note: the next trick would be to spin a separate thread to update
1155   ;; a global value once per internal tick, so each individual call to
1156   ;; get-internal-real-time would be just a memory read... but that is
1157   ;; probably best left for user-level code. ;)
1158   ;;
1159   ;; Thanks to James Anderson for the optimization hint.
1160   ;;
1161   ;; Yes, it is possible to a computation to be GET-INTERNAL-REAL-TIME
1162   ;; bound.
1163   ;;
1164   ;; --NS 2007-04-05
1165   (let ((e-sec 0)
1166         (e-msec 0)
1167         (c-sec 0)
1168         (c-msec 0)
1169         (now 0))
1170     (declare (type (unsigned-byte 32) e-sec c-sec)
1171              (type fixnum e-msec c-msec)
1172              (type unsigned-byte now))
1173     (defun reinit-internal-real-time ()
1174       (setf (values e-sec e-msec) (system-real-time-values)
1175             c-sec 0
1176             c-msec 0))
1177     ;; If two threads call this at the same time, we're still safe, I
1178     ;; believe, as long as NOW is updated before either of C-MSEC or
1179     ;; C-SEC. Same applies to interrupts. --NS
1180     ;;
1181     ;; I believe this is almost correct with x86/x86-64 cache
1182     ;; coherency, but if the new value of C-SEC, C-MSEC can become
1183     ;; visible to another CPU without NOW doing the same then it's
1184     ;; unsafe. It's `almost' correct on x86 because writes by other
1185     ;; processors may become visible in any order provided transitity
1186     ;; holds. With at least three cpus, C-MSEC and C-SEC may be from
1187     ;; different threads and an incorrect value may be returned.
1188     ;; Considering that this failure is not detectable by the caller -
1189     ;; it looks like time passes a bit slowly - and that it should be
1190     ;; an extremely rare occurance I'm inclinded to leave it as it is.
1191     ;; --MG
1192     (defun get-internal-real-time ()
1193       (multiple-value-bind (sec msec) (system-real-time-values)
1194         (unless (and (= msec c-msec) (= sec c-sec))
1195           (setf now (+ (* (- sec e-sec)
1196                           sb!xc:internal-time-units-per-second)
1197                        (- msec e-msec))
1198                 c-msec msec
1199                 c-sec sec))
1200         now)))
1201
1202   (defun system-internal-run-time ()
1203     (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
1204         (unix-fast-getrusage rusage_self)
1205       (declare (ignore ignore)
1206                (type (unsigned-byte 31) utime-sec stime-sec)
1207                ;; (Classic CMU CL had these (MOD 1000000) instead, but
1208                ;; at least in Linux 2.2.12, the type doesn't seem to
1209                ;; be documented anywhere and the observed behavior is
1210                ;; to sometimes return 1000000 exactly.)
1211                (type (integer 0 1000000) utime-usec stime-usec))
1212       (let ((result (+ (* (+ utime-sec stime-sec)
1213                           sb!xc:internal-time-units-per-second)
1214                        (floor (+ utime-usec
1215                                  stime-usec
1216                                  (floor micro-seconds-per-internal-time-unit 2))
1217                               micro-seconds-per-internal-time-unit))))
1218         result))))
1219 \f
1220 ;;; FIXME, KLUDGE: GET-TIME-OF-DAY used to be UNIX-GETTIMEOFDAY, and had a
1221 ;;; primary return value indicating sucess, and also returned timezone
1222 ;;; information -- though the timezone data was not there on Darwin.
1223 ;;; Now we have GET-TIME-OF-DAY, but it turns out that despite SB-UNIX being
1224 ;;; an implementation package UNIX-GETTIMEOFDAY has users in the wild.
1225 ;;; So we're stuck with it for a while -- maybe delete it towards the end
1226 ;;; of 2009.
1227 (defun unix-gettimeofday ()
1228   (multiple-value-bind (sec usec) (get-time-of-day)
1229     (values t sec usec nil nil)))
1230 \f
1231 ;;;; opendir, readdir, closedir, and dirent-name
1232
1233 (declaim (inline unix-opendir))
1234 (defun unix-opendir (namestring &optional (errorp t))
1235   (let ((dir (alien-funcall
1236               (extern-alien "sb_opendir"
1237                             (function system-area-pointer c-string))
1238               namestring)))
1239     (if (zerop (sap-int dir))
1240         (when errorp (simple-perror
1241                       (format nil "Error opening directory ~S"
1242                               namestring)))
1243         dir)))
1244
1245 (declaim (inline unix-readdir))
1246 (defun unix-readdir (dir &optional (errorp t) namestring)
1247   (let ((ent (alien-funcall
1248               (extern-alien "sb_readdir"
1249                             (function system-area-pointer system-area-pointer))
1250                             dir)))
1251     (if (zerop (sap-int ent))
1252         (when errorp (simple-perror
1253                       (format nil "Error reading directory entry~@[ from ~S~]"
1254                               namestring)))
1255         ent)))
1256
1257 (declaim (inline unix-closedir))
1258 (defun unix-closedir (dir &optional (errorp t) namestring)
1259   (let ((r (alien-funcall
1260             (extern-alien "sb_closedir" (function int system-area-pointer))
1261             dir)))
1262     (if (minusp r)
1263         (when errorp (simple-perror
1264                       (format nil "Error closing directory~@[ ~S~]"
1265                               namestring)))
1266         r)))
1267
1268 (declaim (inline unix-dirent-name))
1269 (defun unix-dirent-name (ent)
1270   (alien-funcall
1271    (extern-alien "sb_dirent_name" (function c-string system-area-pointer))
1272    ent))
1273 \f
1274 ;;;; A magic constant for wait3().
1275 ;;;;
1276 ;;;; FIXME: This used to be defined in run-program.lisp as
1277 ;;;; (defconstant wait-wstopped #-svr4 #o177 #+svr4 wait-wuntraced)
1278 ;;;; According to some of the man pages, the #o177 is part of the API
1279 ;;;; for wait3(); that said, under SunOS there is a WSTOPPED thing in
1280 ;;;; the headers that may or may not be the same thing. To be
1281 ;;;; investigated. -- CSR, 2002-03-25
1282 (defconstant wstopped #o177)