source: trunk/source/level-1/linux-files.lisp @ 11081

Last change on this file since 11081 was 11081, checked in by gb, 11 years ago

Stop wrapping (pseudo) file-descriptors around Windows file handlers;
there seem to be cases where this definitely loses, because the MSVCRT
runtime tries to flush buffers associated with (e.g.) a listening socket
when it's closed, and we often have to do I/O in Windows-specific ways
and can't always use the C runtime, anyway.

Handles are (depending on which function you're dealing with) either
pointers or pointer-sized integers; they can be used interchangably
with ints on Win32, but porting this change to Win64 may require some
changes (in l1-io.lisp, in the PIPE function, perhaps elsewhere.)

Supporting this requires some changss in the kernel (mostly in
windows-calls.c) To bootstrap it, most of the I/O functions in
that file assume that very small integers [0 .. 31] are fds wrapped
around a handle and that anything larger is the handle itself. All
of the actual work done by those functions is done on the handle,
without involving the C runtime.

I'll check in a win32 kernel and image in a few minutes. Mixing
older kernels/images won't work, but I don't want to change the
kernel/image compatibility stuff until this is further along.

SLIME sort of works, but not very reliably yet.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 77.0 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19(defconstant unix-to-universal-time 2208988800)
20
21#+windows-target
22(progn
23
24
25           
26
27(defun nbackslash-to-forward-slash (namestring)
28  (dotimes (i (length namestring) namestring)
29    (when (eql (schar namestring i) #\\)
30      (setf (schar namestring i) #\/))))
31
32(defconstant univeral-time-start-in-windows-seconds 9435484800)
33
34(defun windows-filetime-to-universal-time (ft)
35  (let* ((100-ns (dpb (pref ft #>FILETIME.dwHighDateTime) (byte 32 32)
36                      (pref ft #>FILETIME.dwLowDateTime)))
37         (seconds-since-windows-epoch (floor 100-ns 10000000)))
38    (- seconds-since-windows-epoch univeral-time-start-in-windows-seconds)))
39)
40
41(defun get-foreign-namestring (pointer)
42  ;; On Darwin, foreign namestrings are encoded in UTF-8 and
43  ;; are canonically decomposed (NFD).  Use PRECOMPOSE-SIMPLE-STRING
44  ;; to ensure that the string is "precomposed" (NFC), like the
45  ;; rest of the world and most sane people would expect.
46  #+darwin-target
47  (precompose-simple-string (%get-utf-8-cstring pointer))
48  #+windows-target (nbackslash-to-forward-slash
49                     (%get-native-utf-16-cstring pointer))
50  ;; On some other platforms, the namestring is assumed to
51  ;; be encoded according to the current locale's character
52  ;; encoding (though FreeBSD seems to be moving towards
53  ;; precomposed UTF-8.).
54  ;; In any case, the use of %GET-CSTRING here is wrong ...
55  #-(or darwin-target windows-target)
56  (%get-cstring pointer))
57
58(defun nanoseconds (n)
59  (unless (and (typep n 'fixnum)
60               (>= (the fixnum n) 0))
61    (check-type n (real 0 #.(1- (ash 1 (1- target::nbits-in-word))))))
62  (multiple-value-bind (q r)
63      (floor n)
64    (if (zerop r)
65      (setq r 0)
66      (setq r (floor (* r 1000000000))))
67    (values q r)))
68
69(defun milliseconds (n)
70  (unless (and (typep n 'fixnum)
71               (>= (the fixnum n) 0))
72    (check-type n (real 0 #.(1- (ash 1 (1- target::nbits-in-word))))))
73  (multiple-value-bind (q r)
74      (floor n)
75    (if (zerop r)
76      (setq r 0)
77      (setq r (floor (* r 1000))))
78    (values q r)))
79
80(defun microseconds (n)
81  (unless (and (typep n 'fixnum)
82               (>= (the fixnum n) 0))
83    (check-type n (real 0 #.(1- (ash 1 (1- target::nbits-in-word))))))
84  (multiple-value-bind (q r)
85      (floor n)
86    (if (zerop r)
87      (setq r 0)
88      (setq r (floor (* r 1000000))))
89    (values q r)))
90
91(defun semaphore-value (s)
92  (if (istruct-typep s 'semaphore)
93    (semaphore.value s)
94    (semaphore-value (require-type s 'semaphore))))
95
96(defun %wait-on-semaphore-ptr (s seconds milliseconds &optional flag)
97  (if flag
98    (if (istruct-typep flag 'semaphore-notification)
99      (setf (semaphore-notification.status flag) nil)
100      (report-bad-arg flag 'semaphore-notification)))
101  (without-interrupts
102   (let* ((status (ff-call
103                   (%kernel-import target::kernel-import-wait-on-semaphore)
104                   :address s
105                   :unsigned seconds
106                   :unsigned milliseconds
107                   :signed))
108          (result (zerop status)))     
109     (declare (fixnum status))
110     (when flag (setf (semaphore-notification.status flag) result))
111     (values result status))))
112
113(defun %process-wait-on-semaphore-ptr (s seconds milliseconds &optional
114                                         (whostate "semaphore wait") flag)
115  (or (%wait-on-semaphore-ptr s 0 0 flag)
116      (with-process-whostate  (whostate)
117        (loop
118          (when (%wait-on-semaphore-ptr s seconds milliseconds flag)
119            (return))))))
120
121 
122(defun wait-on-semaphore (s &optional flag (whostate "semaphore wait"))
123  "Wait until the given semaphore has a positive count which can be
124atomically decremented."
125  (%process-wait-on-semaphore-ptr (semaphore-value s) #xffffff 0 whostate flag)
126  t)
127
128
129(defun %timed-wait-on-semaphore-ptr (semptr duration notification)
130  (or (%wait-on-semaphore-ptr semptr 0 0 notification)
131      (with-process-whostate ("Semaphore timed wait")
132        (multiple-value-bind (secs millis) (milliseconds duration)
133          (let* ((now (get-internal-real-time))
134                 (stop (+ now
135                          (* secs 1000)
136                          millis)))
137            (loop
138              (multiple-value-bind (success err)
139                  (progn
140                    (%wait-on-semaphore-ptr semptr secs millis notification))
141                (when success
142                  (return t))
143                (when (or (not (eql err #$EINTR))
144                          (>= (setq now (get-internal-real-time)) stop))
145                  (return nil))
146                (unless (zerop duration)
147                  (let* ((diff (- stop now)))
148                    (multiple-value-bind (remaining-seconds remaining-millis)
149                        (floor diff 1000)
150                      (setq secs remaining-seconds
151                            millis remaining-millis)))))))))))
152
153(defun timed-wait-on-semaphore (s duration &optional notification)
154  "Wait until the given semaphore has a postive count which can be
155atomically decremented, or until a timeout expires."
156  (%timed-wait-on-semaphore-ptr (semaphore-value s) duration notification))
157
158
159(defun %signal-semaphore-ptr (p)
160  (ff-call
161   (%kernel-import target::kernel-import-signal-semaphore)
162   :address p
163   :signed-fullword))
164
165(defun signal-semaphore (s)
166  "Atomically increment the count of a given semaphore."
167  (%signal-semaphore-ptr (semaphore-value s)))
168
169(defun %os-getcwd (buf noctets)
170  ;; Return N < 0, if error
171  ;;        N < noctets: success, string is of length N (octets).
172  ;;        N >= noctets: buffer needs to be larger.
173  (let* ((p #+windows-target
174           (#__wgetcwd buf (ash noctets -1))
175           #-windows-target
176           (#_getcwd buf noctets)))
177    (declare (dynamic-extent p))
178    (if (%null-ptr-p p)
179      (let* ((err (%get-errno)))
180        (if (eql err (- #$ERANGE))
181          (+ noctets noctets)
182          err))
183      #+windows-target
184      (do* ((i 0 (+ i 2)))
185           ((= i noctets) (+ noctets noctets))
186        (when (eql (%get-unsigned-word buf i) 0)
187          (return i)))
188      #-windows-target
189      (dotimes (i noctets (+ noctets noctets))
190        (when (eql 0 (%get-byte buf i))
191          (return i))))))
192   
193   
194(defun current-directory-name ()
195  "Look up the current working directory of the OpenMCL process; unless
196it has been changed, this is the directory OpenMCL was started in."
197  (flet ((try-getting-dirname (bufsize)
198           (%stack-block ((buf bufsize))
199             (let* ((len (%os-getcwd buf bufsize)))
200               (cond ((< len 0) (%errno-disp len))
201                     ((< len bufsize)
202                      (values (get-foreign-namestring buf) len))
203                     (t (values nil len)))))))
204    (do* ((string nil)
205          (len #+windows-target 128 #-windows-target 64)
206          (bufsize len len))
207         ((multiple-value-setq (string len) (try-getting-dirname bufsize))
208          string))))
209
210
211(defun current-directory ()
212  (mac-default-directory))
213
214(defun (setf current-directory) (path)
215  (cwd path)
216  path)
217
218(defun cd (path)
219  (cwd path))
220
221
222
223
224(defun %chdir (dirname)
225  (with-filename-cstrs ((dirname dirname))
226    (int-errno-call (#+windows-target #__wchdir #-windows-target #_chdir dirname))))
227
228(defun %mkdir (name mode)
229  #+windows-target (declare (ignore mode))
230  (let* ((name name)
231         (len (length name)))
232    (when (and (> len 0) (eql (char name (1- len)) #\/))
233      (setq name (subseq name 0 (1- len))))
234    (with-filename-cstrs ((name name))
235      (int-errno-call (#+windows-target #__wmkdir #-windows-target #_mkdir  name #-windows-target mode)))))
236
237(defun %rmdir (name)
238  (let* ((last (1- (length name))))
239    (with-filename-cstrs ((name name))
240      (when (and (>= last 0)
241                 (eql (%get-byte name last) (char-code #\/)))
242        (setf (%get-byte name last) 0))
243      (int-errno-call (#+windows-target #__wrmdir #-windows-target #_rmdir  name)))))
244
245
246(defun getenv (key)
247  "Look up the value of the environment variable named by name, in the
248OS environment."
249  (with-cstrs ((key (string key)))
250    (let* ((env-ptr (%null-ptr)))
251      (declare (dynamic-extent env-ptr))
252      (%setf-macptr env-ptr (#_getenv key))
253      (unless (%null-ptr-p env-ptr)
254        (%get-cstring env-ptr))))
255  )
256
257(defun setenv (key value &optional (overwrite t))
258  "Set the value of the environment variable named by name, in the OS
259environment. If there is no such environment variable, create it."
260  #+windows-target (declare (ignore overwrite))
261  #-windows-target
262  (with-cstrs ((ckey key)
263               (cvalue value))
264    (#_setenv ckey cvalue (if overwrite 1 0)))
265  #+windows-target
266  (with-cstrs ((pair (format nil "~a=~a" key value)))
267    (#__putenv pair))
268  )
269
270#-windows-target                        ; Windows "impersonation" crap ?
271(defun setuid (uid)
272  "Attempt to change the current user ID (both real and effective);
273fails unless the OpenMCL process has super-user privileges or the ID
274given is that of the current user."
275  (int-errno-call (#_setuid uid)))
276
277#-windows-target
278(defun setgid (uid)
279  "Attempt to change the current group ID (both real and effective);
280fails unless the OpenMCL process has super-user privileges or the ID
281given is that of a group to which the current user belongs."
282  (int-errno-call (#_setgid uid)))
283 
284
285;;; On Linux, "stat" & friends are implemented in terms of deeper,
286;;; darker things that need to know what version of the stat buffer
287;;; they're talking about.
288
289#-windows-target
290(defun %stat-values (result stat)
291  (if (eql 0 (the fixnum result)) 
292      (values
293       t
294       (pref stat :stat.st_mode)
295       (pref stat :stat.st_size)
296       #+(or linux-target solaris-target)
297       (pref stat :stat.st_mtim.tv_sec)
298       #-(or linux-target solaris-target)
299       (pref stat :stat.st_mtimespec.tv_sec)
300       (pref stat :stat.st_ino)
301       (pref stat :stat.st_uid)
302       (pref stat :stat.st_blksize)
303       #+(or linux-target solaris-target)
304       (round (pref stat :stat.st_mtim.tv_nsec) 1000)
305       #-(or linux-target solaris-target)
306       (round (pref stat :stat.st_mtimespec.tv_nsec) 1000)
307       (pref stat :stat.st_gid))
308      (values nil nil nil nil nil nil nil)))
309
310#+win64-target
311(defun %stat-values (result stat)
312  (if (eql 0 (the fixnum result)) 
313      (values
314       t
315       (pref stat :_stat64.st_mode)
316       (pref stat :_stat64.st_size)
317       (pref stat :_stat64.st_mtime)
318       (pref stat :_stat64.st_ino)
319       (pref stat :_stat64.st_uid)
320       #$BUFSIZ
321       (pref stat :_stat64.st_mtime)     ; ???
322       (pref stat :_stat64.st_gid))
323      (values nil nil nil nil nil nil nil nil nil)))
324
325#+win32-target
326(defun %stat-values (result stat)
327  (if (eql 0 (the fixnum result)) 
328      (values
329       t
330       (pref stat :__stat64.st_mode)
331       (pref stat :__stat64.st_size)
332       (pref stat :__stat64.st_mtime)
333       (pref stat :__stat64.st_ino)
334       (pref stat :__stat64.st_uid)
335       #$BUFSIZ
336       (pref stat :__stat64.st_mtime)     ; ???
337       (pref stat :__stat64.st_gid))
338      (values nil nil nil nil nil nil nil nil nil)))
339
340#+windows-target
341(defun windows-strip-trailing-slash (namestring)
342  (do* ((len (length namestring) (length namestring)))
343       ((<= len 3) namestring)
344    (let* ((p (1- len))
345           (ch (char namestring p)))
346      (unless (or (eql ch #\\)
347                  (eql ch #\/))
348        (return namestring))
349      (setq namestring (subseq namestring 0 p)))))
350
351
352(defun %%stat (name stat)
353  (with-filename-cstrs ((cname #+windows-target (windows-strip-trailing-slash name) #-windows-target name))
354    (%stat-values
355     #+linux-target
356     (#_ __xstat #$_STAT_VER_LINUX cname stat)
357     #-linux-target
358     (int-errno-ffcall (%kernel-import target::kernel-import-lisp-stat)
359                       :address cname
360                       :address stat
361                       :int)
362     stat)))
363
364(defun %%fstat (fd stat)
365  (%stat-values
366   #+linux-target
367   (#_ __fxstat #$_STAT_VER_LINUX fd stat)
368   #-linux-target
369   (int-errno-ffcall (%kernel-import target::kernel-import-lisp-fstat)
370                     :int fd
371                     :address stat
372                     :int)
373   stat))
374
375#-windows-target
376(defun %%lstat (name stat)
377  (with-filename-cstrs ((cname name))
378    (%stat-values
379     #+linux-target
380     (#_ __lxstat #$_STAT_VER_LINUX cname stat)
381     #-linux-target
382     (#_lstat cname stat)
383     stat)))
384
385
386;;; Returns: (values t mode size mtime inode uid blksize) on success,
387;;;          (values nil nil nil nil nil nil nil) otherwise
388;;; NAME should be a "native namestring", e.g,, have all lisp pathname
389;;; escaping removed.
390#-windows-target
391(defun %stat (name &optional link-p)
392  (rlet ((stat :stat))
393    (if link-p
394      (%%lstat name stat)
395      (%%stat name stat))))
396
397#+windows-target
398(defun %stat (name &optional link-p)
399  (declare (ignore link-p))
400  (rlet ((stat  #+win64-target #>_stat64 #+win32-target #>__stat64))
401    (%%stat name stat)))
402
403(defun %fstat (fd)
404  (rlet ((stat #+win64-target #>_stat64 #+win32-target #>__stat64 #-windows-target :stat))
405    (%%fstat fd stat)))
406
407
408(defun %file-kind (mode &optional fd)
409  (declare (ignorable fd))
410  (when mode
411    (let* ((kind (logand mode #$S_IFMT)))
412      (cond ((eql kind #$S_IFDIR) :directory)
413            ((eql kind #$S_IFREG) :file)
414            #-windows-target
415            ((eql kind #$S_IFLNK) :link)
416            ((eql kind #$S_IFIFO) 
417             #-windows-target :pipe
418             ;; Windows doesn't seem to be able to distinguish between
419             ;; sockets and pipes.  Since this function is currently
420             ;; (mostly) used for printing streams and since we've
421             ;; already done something fairly expensive (stat, fstat)
422             ;; to get here.  try to distinguish between pipes and
423             ;; sockets by calling #_getsockopt.  If that succeeds,
424             ;; we've got a socket; otherwise, we're probably got a pipe.
425             #+windows-target (rlet ((ptype :int)
426                                     (plen :int 4))
427                                (if (and fd (eql 0 (#_getsockopt fd #$SOL_SOCKET #$SO_TYPE  ptype plen)))
428                                    :socket
429                                    :pipe)))
430            #-windows-target
431            ((eql kind #$S_IFSOCK) :socket)
432            ((eql kind #$S_IFCHR) :character-special)
433            (t :special)))))
434
435(defun %unix-file-kind (native-namestring &optional check-for-link)
436  (%file-kind (nth-value 1 (%stat native-namestring check-for-link))))
437
438(defun %unix-fd-kind (fd)
439  (if (isatty fd)
440    :tty
441    (%file-kind (nth-value 1 (%fstat fd)) fd)))
442
443#-windows-target
444(defun %uts-string (result idx buf)
445  (if (>= result 0)
446    (%get-cstring (%inc-ptr buf (* #+linux-target #$_UTSNAME_LENGTH
447                                   #+darwin-target #$_SYS_NAMELEN
448                                   #+(or freebsd-target solaris-target) #$SYS_NMLN
449                                   idx)))
450    "unknown"))
451
452#-windows-target
453(defun copy-file-attributes (source-path dest-path)
454  "Copy the mode, owner, group and modification time of source-path to dest-path.
455   Returns T if succeeded, NIL if some of the attributes couldn't be copied due to
456   permission problems.  Any other failures cause an error to be signalled"
457  (multiple-value-bind (win mode ignore mtime-sec ignore uid ignore mtime-usec gid)
458                       (%stat (native-translated-namestring source-path) t)
459    (declare (ignore ignore))
460    (unless win
461      (error "Cannot get attributes of ~s" source-path))
462    (with-filename-cstrs ((cnamestr (native-translated-namestring dest-path)))
463      (macrolet ((errchk (form)
464                   `(let ((err ,form))
465                      (unless (eql err 0)
466                        (setq win nil)
467                        (when (eql err -1)
468                          (setq err (- (%get-errno))))
469                        (unless (eql err #$EPERM) (%errno-disp err dest-path))))))
470        (errchk (#_chmod cnamestr mode))
471        (errchk (%stack-block ((times (record-length (:array (:struct :timeval) 2))))
472                  (setf (pref times :timeval.tv_sec) mtime-sec)
473                  (setf (pref times :timeval.tv_usec) mtime-usec)
474                  (%incf-ptr times (record-length :timeval))
475                  (setf (pref times :timeval.tv_sec) mtime-sec)
476                  (setf (pref times :timeval.tv_usec) mtime-usec)
477                  (%incf-ptr times (- (record-length :timeval)))
478                  (#_utimes cnamestr times)))
479        (errchk (#_chown cnamestr uid gid))))
480    win))
481
482#+windows-target
483(defun copy-file-attributes (source-path dest-path)
484  "could at least copy the file times"
485  (declare (ignore source-path dest-path)))
486
487
488#+linux-target
489(defun %uname (idx)
490  (%stack-block ((buf (* #$_UTSNAME_LENGTH 6))) 
491    (%uts-string (#_uname buf) idx buf)))
492
493#+darwin-target
494(defun %uname (idx)
495  (%stack-block ((buf (* #$_SYS_NAMELEN 5)))
496    (%uts-string (#_uname buf) idx buf)))
497
498#+freebsd-target
499(defun %uname (idx)
500  (%stack-block ((buf (* #$SYS_NMLN 5)))
501    (%uts-string (#___xuname #$SYS_NMLN buf) idx buf)))
502
503#+solaris-target
504(defun %uname (idx)
505  (%stack-block ((buf (* #$SYS_NMLN 5)))
506    (%uts-string (#_uname buf) idx buf)))
507
508#-windows-target
509(defun fd-dup (fd)
510  (int-errno-call (#_dup fd)))
511
512#+windows-target
513(defun fd-dup (fd &key direction inheritable)
514  (declare (ignore direction))
515  (rlet ((handle #>HANDLE))
516    (#_DuplicateHandle (#_GetCurrentProcess)
517                       fd
518                       (#_GetCurrentProcess) 
519                       handle
520                       0
521                       (if inheritable #$TRUE #$FALSE)
522                       #$DUPLICATE_SAME_ACCESS)))
523                       
524
525(defun fd-fsync (fd)
526  #+windows-target (#_FlushFileBuffers fd)
527  #-windows-target
528  (int-errno-call (#_fsync fd)))
529
530#-windows-target
531(progn
532(defun fd-get-flags (fd)
533  (int-errno-call (#_fcntl fd #$F_GETFL)))
534
535(defun fd-set-flags (fd new)
536  (int-errno-call (#_fcntl fd #$F_SETFL :int new)))
537
538(defun fd-set-flag (fd mask)
539  (let* ((old (fd-get-flags fd)))
540    (if (< old 0)
541      old
542      (fd-set-flags fd (logior old mask)))))
543
544(defun fd-clear-flag (fd mask)
545  (let* ((old (fd-get-flags fd)))
546    (if (< old 0) 
547      old
548      (fd-set-flags fd (logandc2 old mask)))))
549)
550
551;;; Assume that any quoting's been removed already.
552(defun tilde-expand (namestring)
553  (let* ((len (length namestring)))
554    (if (or (zerop len)
555            (not (eql (schar namestring 0) #\~)))
556      namestring
557      (if (or (= len 1)
558              (eql (schar namestring 1) #\/))
559        (concatenate 'string (get-user-home-dir (getuid)) (if (= len 1) "/" (subseq namestring 1)))
560        #+windows-target namestring
561        #-windows-target
562        (let* ((slash-pos (position #\/ namestring))
563               (user-name (subseq namestring 1 slash-pos))
564               (uid (or (get-uid-from-name user-name)
565                        (error "Unknown user ~s in namestring ~s" user-name namestring))))
566          (concatenate 'string (get-user-home-dir uid) (if slash-pos (subseq namestring slash-pos) "/")))))))
567
568
569#+windows-target
570(defun %windows-realpath (namestring)
571  (with-filename-cstrs ((path namestring))
572    (do* ((bufsize 256))
573         ()
574      (%stack-block ((buf bufsize))
575        (let* ((nchars (#_GetFullPathNameW path (ash bufsize -1) buf (%null-ptr))))
576          (if (eql 0 nchars)
577            (return nil)
578            (let* ((max (+ nchars nchars 2)))
579              (if (> max bufsize)
580                (setq bufsize max)
581                (let* ((real (get-foreign-namestring buf)))
582                  (return (and (%stat real) real)))))))))))
583
584   
585;;; This doesn't seem to exist on VxWorks.  It's a POSIX
586;;; function AFAIK, so the source should be somewhere ...
587
588(defun %realpath (namestring)
589  ;; It's not at all right to just return the namestring here.
590  (when (zerop (length namestring))
591    (setq namestring (current-directory-name)))
592  #+windows-target (%windows-realpath namestring)
593  #-windows-target
594  (%stack-block ((resultbuf #$PATH_MAX))
595    (with-filename-cstrs ((name namestring #|(tilde-expand namestring)|#))
596      (let* ((result (#_realpath name resultbuf)))
597        (declare (dynamic-extent result))
598        (unless (%null-ptr-p result)
599          (get-foreign-namestring result))))))
600
601;;; Return fully resolved pathname & file kind, or (values nil nil)
602
603(defun %probe-file-x (namestring)
604  (let* ((realpath (%realpath namestring))
605         (kind (if realpath (%unix-file-kind realpath))))
606    (if kind
607      (values realpath kind)
608      (values nil nil))))
609
610;;; The mingw headers define timeval.tv_sec and timeval.tv_usec to be
611;;; signed 32-bit quantities.
612(macrolet ((timeval-ref (ptr accessor)
613             #+windows-target `(logand #xfffffffff (pref ,ptr ,accessor))
614             #-windows-target `(pref ,ptr ,accessor))
615           (set-timeval-ref (ptr accessor new)
616           `(setf (pref ,ptr ,accessor)
617             #+windows-target (u32->s32 ,new)
618             #-windows-target ,new)))
619 
620(defun timeval->milliseconds (tv)
621    (+ (* 1000 (timeval-ref tv :timeval.tv_sec)) (round (timeval-ref tv :timeval.tv_usec) 1000)))
622
623(defun timeval->microseconds (tv)
624    (+ (* 1000000 (timeval-ref tv :timeval.tv_sec)) (timeval-ref tv :timeval.tv_usec)))
625
626(defun %add-timevals (result a b)
627  (let* ((seconds (+ (timeval-ref a :timeval.tv_sec) (timeval-ref b :timeval.tv_sec)))
628         (micros (+ (timeval-ref a :timeval.tv_usec) (timeval-ref b :timeval.tv_usec))))
629    (if (>= micros 1000000)
630      (setq seconds (1+ seconds) micros (- micros 1000000)))
631    (set-timeval-ref result :timeval.tv_sec seconds)
632    (set-timeval-ref result :timeval.tv_usec micros)
633    result))
634
635(defun %sub-timevals (result a b)
636  (let* ((seconds (- (timeval-ref a :timeval.tv_sec) (timeval-ref b :timeval.tv_sec)))
637         (micros (- (timeval-ref a :timeval.tv_usec) (timeval-ref b :timeval.tv_usec))))
638    (if (< micros 0)
639      (setq seconds (1- seconds) micros (+ micros 1000000)))
640    (set-timeval-ref result :timeval.tv_sec  seconds)
641    (set-timeval-ref result :timeval.tv_usec micros)
642    result))
643
644;;; Return T iff the time denoted by the timeval a is not later than the
645;;; time denoted by the timeval b.
646(defun %timeval<= (a b)
647  (let* ((asec (timeval-ref a :timeval.tv_sec))
648         (bsec (timeval-ref b :timeval.tv_sec)))
649    (or (< asec bsec)
650        (and (= asec bsec)
651             (< (timeval-ref a :timeval.tv_usec)
652                (timeval-ref b :timeval.tv_usec))))))
653
654); windows signed nonsense.
655
656#-windows-target
657(defun %%rusage (usage &optional (who #$RUSAGE_SELF))
658  (int-errno-call (#_getrusage who usage)))
659
660
661
662
663(defun %file-write-date (namestring)
664  (let* ((date (nth-value 3 (%stat namestring))))
665    (if date
666      (+ date unix-to-universal-time))))
667
668#-windows-target
669(defun %file-author (namestring)
670  (let* ((uid (nth-value 5 (%stat namestring))))
671    (if uid
672      (with-macptrs ((pw (#_getpwuid uid)))
673        (unless (%null-ptr-p pw)
674          (without-interrupts
675           (%get-cstring (pref pw :passwd.pw_name))))))))
676
677#+windows-target
678(defun %file-author (namestring)
679  (declare (ignore namestring))
680  nil)
681
682#-windows-target
683(defun %utimes (namestring)
684  (with-filename-cstrs ((cnamestring namestring))
685    (let* ((err (#_utimes cnamestring (%null-ptr))))
686      (declare (fixnum err))
687      (or (eql err 0)
688          (%errno-disp err namestring)))))
689
690#+windows-target
691(defun %utimes (namestring)
692  (with-filename-cstrs ((cnamestring namestring))
693    (let* ((handle (#_CreateFileW
694                    cnamestring
695                    #$FILE_WRITE_ATTRIBUTES
696                    (logior #$FILE_SHARE_READ #$FILE_SHARE_WRITE)
697                    (%null-ptr)
698                    #$OPEN_EXISTING
699                    #$FILE_ATTRIBUTE_NORMAL
700                    (%null-ptr))))
701      (if (eql handle *windows-invalid-handle*)
702        (%windows-error-disp (#_GetLastError))
703        (rlet ((st #>SYSTEMTIME)
704               (ft #>FILETIME))
705          (#_GetSystemTime st)
706          (#_SystemTimeToFileTime st ft)
707          (let* ((result (#_SetFileTime handle (%null-ptr) (%null-ptr) ft))
708                 (err (unless (eql 0 result) (#_GetLastError))))
709            (#_CloseHandle handle)
710            (if err
711              (%windows-error-disp err)
712              t)))))))
713
714
715             
716
717#-windows-target
718(defun get-uid-from-name (name)
719  (with-cstrs ((name name))
720    (let* ((pwent (#_getpwnam name)))
721      (unless (%null-ptr-p pwent)
722        (pref pwent :passwd.pw_uid)))))
723
724
725(defun isatty (fd)
726  #+windows-target (declare (ignore fd))
727  #+windows-target nil
728  #-windows-target
729  (= 1 (#_isatty fd)))
730
731(defun %open-dir (namestring)
732  (with-filename-cstrs ((name namestring))
733    (let* ((DIR (ff-call (%kernel-import target::kernel-import-lisp-opendir)
734                         :address name
735                         :address)))
736      (unless (%null-ptr-p DIR)
737        DIR))))
738
739(defun close-dir (dir)
740  (ff-call (%kernel-import target::kernel-import-lisp-closedir)
741           :address dir
742           :int))
743
744(defun %read-dir (dir)
745  (let* ((res (ff-call (%kernel-import target::kernel-import-lisp-readdir)
746                       :address dir
747                       :address)))
748    (unless (%null-ptr-p res)
749      (get-foreign-namestring (pref res
750                                    #+windows-target :_wdirent.d_name
751                                    #-windows-target :dirent.d_name)))))
752
753
754#-windows-target
755(defun tcgetpgrp (fd)
756  (#_tcgetpgrp fd))
757
758(defun getpid ()
759  "Return the ID of the OpenMCL OS process."
760  #-windows-target
761  (int-errno-call (#_getpid))
762  #+windows-target (#_GetCurrentProcessId))
763
764
765(defun getuid ()
766  "Return the (real) user ID of the current user."
767  #+windows-target 0
768  #-windows-target (int-errno-call (#_getuid)))
769
770(defun get-user-home-dir (userid)
771  "Look up and return the defined home directory of the user identified
772by uid. This value comes from the OS user database, not from the $HOME
773environment variable. Returns NIL if there is no user with the ID uid."
774  #+windows-target
775  (declare (ignore userid))
776  #+windows-target
777  (dolist (k '(#||"HOME"||# "USERPROFILE")) 
778    (with-native-utf-16-cstrs ((key k))
779      (let* ((p (#__wgetenv key)))
780        (unless (%null-ptr-p p)
781          (return (get-foreign-namestring p))))))
782  #-windows-target
783  (rlet ((pwd :passwd)
784         (result :address))
785    (do* ((buflen 512 (* 2 buflen)))
786         ()
787      (%stack-block ((buf buflen))
788        (let* ((err
789                #-solaris-target
790                 (#_getpwuid_r userid pwd buf buflen result)
791                 #+solaris-target
792                 (external-call "__posix_getpwuid_r"
793                                :uid_t userid
794                                :address pwd
795                                :address buf
796                                :int buflen
797                                :address result
798                                :int)))
799          (if (eql 0 err)
800            (return (get-foreign-namestring (pref pwd :passwd.pw_dir)))
801            (unless (eql err #$ERANGE)
802              (return nil))))))))
803
804(defun %delete-file (name)
805  (with-cstrs ((n name))
806    (int-errno-call (#+windows-target #__unlink #-windows-target #_unlink n))))
807
808(defun os-command (string)
809  "Invoke the Posix function system(), which invokes the user's default
810system shell (such as sh or tcsh) as a new process, and has that shell
811execute command-line.
812
813If the shell was able to find the command specified in command-line, then
814exit-code is the exit code of that command. If not, it is the exit code
815of the shell itself."
816  (with-cstrs ((s string))
817    (#_system s)))
818
819(defun %strerror (errno)
820  (declare (fixnum errno))
821  (if (< errno 0)
822    (setq errno (- errno)))
823  (with-macptrs (p)
824    (%setf-macptr p (#_strerror errno))
825    (if (%null-ptr-p p)
826      (format nil "OS Error %d" errno)
827      (%get-cstring p))))
828
829#+windows-target
830(defun %windows-error-string (error-number) 
831  (rlet ((pbuffer :address (%null-ptr)))
832    (if (eql 0
833             (#_FormatMessageW (logior #$FORMAT_MESSAGE_ALLOCATE_BUFFER
834                                       #$FORMAT_MESSAGE_FROM_SYSTEM
835                                       #$FORMAT_MESSAGE_IGNORE_INSERTS
836                                       #$FORMAT_MESSAGE_MAX_WIDTH_MASK)
837                               (%null-ptr)
838                               (abs error-number)
839                               0                 ; default langid, more-or-less
840                               pbuffer
841                               0
842                               (%null-ptr)))
843      (format nil "Windows error ~d" (abs error-number))
844      (let* ((p (%get-ptr pbuffer))
845             (q (%get-native-utf-16-cstring p)))
846        (#_LocalFree p)
847        q))))
848       
849                     
850
851;;; Kind of has something to do with files, and doesn't work in level-0.
852#+(or linux-target freebsd-target solaris-target)
853(defun close-shared-library (lib &key (completely t))
854  "If completely is T, set the reference count of library to 0. Otherwise,
855decrements it by 1. In either case, if the reference count becomes 0,
856close-shared-library frees all memory resources consumed library and causes
857any EXTERNAL-ENTRY-POINTs known to be defined by it to become unresolved."
858  (let* ((lib (if (typep lib 'string)
859                (or (shared-library-with-name lib)
860                    (error "Shared library ~s not found." lib))
861                (require-type lib 'shlib)))
862         (handle (shlib.handle lib)))
863      (when handle
864        (let* ((found nil)
865               (base (shlib.base lib)))
866          (do* ()
867               ((progn           
868                  (#_dlclose handle)
869                  (or (not (setq found (shlib-containing-address base)))
870                      (not completely)))))
871          (when (not found)
872            (setf (shlib.pathname lib) nil
873              (shlib.base lib) nil
874              (shlib.handle lib) nil
875              (shlib.map lib) nil)
876            (unload-foreign-variables lib)
877            (unload-library-entrypoints lib))))))
878
879#+darwin-target
880;; completely specifies whether to remove it totally from our list
881(defun close-shared-library (lib &key (completely nil))
882  "If completely is T, set the reference count of library to 0. Otherwise,
883decrements it by 1. In either case, if the reference count becomes 0,
884close-shared-library frees all memory resources consumed library and causes
885any EXTERNAL-ENTRY-POINTs known to be defined by it to become unresolved."
886  (let* ((lib (if (typep lib 'string)
887                  (or (shared-library-with-name lib)
888                      (error "Shared library ~s not found." lib))
889                (require-type lib 'shlib))))
890    ;; no possible danger closing libsystem since dylibs can't be closed
891    (cond
892     ((or (not (shlib.map lib)) (not (shlib.base lib)))
893      (error "Shared library ~s uninitialized." (shlib.soname lib)))
894     ((and (not (%null-ptr-p (shlib.map lib)))
895           (%null-ptr-p (shlib.base lib)))
896      (warn "Dynamic libraries cannot be closed on Darwin."))
897     ((and (%null-ptr-p (shlib.map lib))
898           (not (%null-ptr-p (shlib.base lib))))
899      ;; we have a bundle type library not sure what to do with the
900      ;; completely flag when we open the same bundle more than once,
901      ;; Darwin gives back a new module address, so we have multiple
902      ;; entries on *shared-libraries* the best we can do is unlink
903      ;; the module asked for (or our best guess based on name) and
904      ;; invalidate any entries which refer to this container
905      (if (= 0 (#_NSUnLinkModule (shlib.base lib) #$NSUNLINKMODULE_OPTION_NONE))
906          (error "Unable to close shared library, NSUnlinkModule failed.")
907        (progn
908          (setf (shlib.map lib) nil
909                (shlib.base lib) nil)
910          (unload-library-entrypoints lib)
911          (when completely
912            (setq *shared-libraries* (delete lib *shared-libraries*)))))))))
913
914
915
916;;; Foreign (unix) processes.
917
918(defun call-with-string-vector (function strings)
919  (let ((bufsize (reduce #'+ strings
920                         :key #'(lambda (s) (1+ (length (string s))))))
921        (argvsize (ash (1+ (length strings)) target::word-shift))
922        (bufpos 0)
923        (argvpos 0))
924    (%stack-block ((buf bufsize) (argv argvsize))
925      (flet ((init (s)
926             (multiple-value-bind (sstr start end) (get-sstring s)
927               (declare (fixnum start end))
928               (let ((len (- end start)))
929                 (declare (fixnum len))
930                 (do* ((i 0 (1+ i))
931                       (start start (1+ start))
932                       (bufpos bufpos (1+ bufpos)))
933                      ((= i len))
934                   (setf (%get-unsigned-byte buf bufpos)
935                         (logand #xff (%scharcode sstr start))))
936                 (setf (%get-byte buf (%i+ bufpos len)) 0)
937                 (setf (%get-ptr argv argvpos) (%inc-ptr buf bufpos))
938                 (setq bufpos (%i+ bufpos len 1))
939                 (setq argvpos (%i+ argvpos target::node-size))))))
940        (declare (dynamic-extent #'init))
941        (map nil #'init strings))
942      (setf (%get-ptr argv argvpos) (%null-ptr))
943      (funcall function argv))))
944
945(defmacro with-string-vector ((var &rest strings) &body body)
946  `(call-with-string-vector #'(lambda (,var) ,@body) ,@strings))
947
948(defloadvar *max-os-open-files* #-windows-target (#_getdtablesize) #+windows-target 32)
949
950(defun pipe ()
951  ;;  (rlet ((filedes (:array :int 2)))
952  (%stack-block ((filedes 8))
953    (let* ((status (ff-call (%kernel-import target::kernel-import-lisp-pipe)
954                            :address filedes :int))
955           (errno (if (eql status 0) 0 (%get-errno))))
956      (unless (zerop status)
957        (when (or (eql errno (- #$EMFILE))
958                  (eql errno (- #$ENFILE)))
959          (gc)
960          (drain-termination-queue)
961          (setq status (ff-call (%kernel-import target::kernel-import-lisp-pipe)
962                            :address filedes :int)
963                errno (if (zerop status) 0 (%get-errno)))))
964      (if (zerop status)
965        (values (paref filedes (:array :int)  0) (paref filedes (:array :int)  1))
966        (%errno-disp errno)))))
967
968#-windows-target
969(progn
970(defun %execvp (argv)
971  (#_execvp (%get-ptr argv) argv)
972  (#_exit #$EX_OSERR))
973
974(defun exec-with-io-redirection (new-in new-out new-err argv)
975  (#_setpgid 0 0)
976  (if new-in (#_dup2 new-in 0))
977  (if new-out (#_dup2 new-out 1))
978  (if new-err (#_dup2 new-err 2))
979  (do* ((fd 3 (1+ fd)))
980       ((= fd *max-os-open-files*) (%execvp argv))
981    (declare (fixnum fd))
982    (#_close fd)))
983
984
985
986
987
988(defstruct external-process
989  pid
990  %status
991  %exit-code
992  pty
993  input
994  output
995  error
996  status-hook
997  plist
998  token
999  core
1000  args
1001  (signal (make-semaphore))
1002  (completed (make-semaphore))
1003  watched-fd
1004  watched-stream
1005  )
1006
1007(defmethod print-object ((p external-process) stream)
1008  (print-unreadable-object (p stream :type t :identity t)
1009    (let* ((status (external-process-%status p)))
1010      (let* ((*print-length* 3))
1011        (format stream "~a" (external-process-args p)))
1012      (format stream "[~d] (~a" (external-process-pid p) status)
1013      (unless (eq status :running)
1014        (format stream " : ~d" (external-process-%exit-code p)))
1015      (format stream ")"))))
1016
1017(defun get-descriptor-for (object proc close-in-parent close-on-error
1018                                  &rest keys &key direction (element-type 'character)
1019                                  &allow-other-keys)
1020  (etypecase object
1021    ((eql t)
1022     (values nil nil close-in-parent close-on-error))
1023    (null
1024     (let* ((null-device #+windows-target "nul" #-windows-target "/dev/null")
1025            (fd (fd-open null-device (case direction
1026                                       (:input #$O_RDONLY)
1027                                       (:output #$O_WRONLY)
1028                                       (t #$O_RDWR)))))
1029       (if (< fd 0)
1030         (signal-file-error fd null-device))
1031       (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
1032    ((eql :stream)
1033     (multiple-value-bind (read-pipe write-pipe) (pipe)
1034       (case direction
1035         (:input
1036          (values read-pipe
1037                  (make-fd-stream write-pipe
1038                                  :direction :output
1039                                  :element-type element-type
1040                                  :interactive nil
1041                                  :basic t
1042                                  :auto-close t)
1043                  (cons read-pipe close-in-parent)
1044                  (cons write-pipe close-on-error)))
1045         (:output
1046          (values write-pipe
1047                  (make-fd-stream read-pipe
1048                                  :direction :input
1049                                  :element-type element-type
1050                                  :interactive nil
1051                                  :basic t
1052                                  :auto-close t)
1053                  (cons write-pipe close-in-parent)
1054                  (cons read-pipe close-on-error)))
1055         (t
1056          (fd-close read-pipe)
1057          (fd-close write-pipe)
1058          (report-bad-arg direction '(member :input :output))))))
1059    ((or pathname string)
1060     (with-open-stream (file (apply #'open object keys))
1061       (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)))))
1062         (values fd
1063                 nil
1064                 (cons fd close-in-parent)
1065                 (cons fd close-on-error)))))
1066    (fd-stream
1067     (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
1068       (values fd
1069               nil
1070               (cons fd close-in-parent)
1071               (cons fd close-on-error))))
1072    (stream
1073     (ecase direction
1074       (:input
1075        (with-cstrs ((template "lisp-tempXXXXXX"))
1076          (let* ((fd (#_mkstemp template)))
1077            (if (< fd 0)
1078              (%errno-disp fd))
1079            (#_unlink template)
1080            (loop
1081              (multiple-value-bind (line no-newline)
1082                  (read-line object nil nil)
1083                (unless line
1084                  (return))
1085                (let* ((len (length line)))
1086                  (%stack-block ((buf (1+ len)))
1087                    (%cstr-pointer line buf)
1088                    (fd-write fd buf len)
1089                    (if no-newline
1090                      (return))
1091                    (setf (%get-byte buf) (char-code #\newline))
1092                    (fd-write fd buf 1)))))
1093            (fd-lseek fd 0 #$SEEK_SET)
1094            (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))))
1095       (:output
1096        (multiple-value-bind (read-pipe write-pipe) (pipe)
1097          (setf (external-process-watched-fd proc) read-pipe
1098                (external-process-watched-stream proc) object)
1099          (incf (car (external-process-token proc)))
1100          (values write-pipe
1101                  nil
1102                  (cons write-pipe close-in-parent)
1103                  (cons read-pipe close-on-error))))))))
1104
1105(let* ((external-processes ())
1106       (external-processes-lock (make-lock)))
1107  (defun add-external-process (p)
1108    (with-lock-grabbed (external-processes-lock)
1109      (push p external-processes)))
1110  (defun remove-external-process (p)
1111    (with-lock-grabbed (external-processes-lock)
1112      (setq external-processes (delete p external-processes))))
1113  ;; Likewise
1114  (defun external-processes ()
1115    (with-lock-grabbed (external-processes-lock)
1116      (copy-list external-processes)))
1117  )
1118
1119
1120(defmacro wtermsig (status)
1121  `(ldb (byte 7 0) ,status))
1122
1123(defmacro wexitstatus (status)
1124  `(ldb (byte 8 8) (the fixnum ,status)))
1125
1126(defmacro wstopsig (status)
1127  `(wexitstatus ,status))
1128
1129(defmacro wifexited (status)
1130  `(eql (wtermsig ,status) 0))
1131
1132(defmacro wifstopped (status)
1133  `(eql #x7f (ldb (byte 7 0) (the fixnum ,status))))
1134
1135(defun monitor-external-process (p)
1136  (let* ((in-fd (external-process-watched-fd p))
1137         (out-stream (external-process-watched-stream p))
1138         (token (external-process-token p))
1139         (terminated))
1140    (loop
1141      (when (and terminated (null in-fd))
1142        (signal-semaphore (external-process-completed p))
1143        (return))
1144      (when in-fd
1145        (when (fd-input-available-p in-fd 1000)
1146          (%stack-block ((buf 1024))
1147            (let* ((n (fd-read in-fd buf 1024)))
1148              (declare (fixnum n))
1149              (if (<= n 0)
1150                (progn
1151                  (without-interrupts
1152                   (decf (car token))
1153                   (fd-close in-fd)
1154                   (setq in-fd nil)))
1155                (let* ((string (make-string 1024)))
1156                  (declare (dynamic-extent string))
1157                  (%str-from-ptr buf n string)
1158                  (write-sequence string out-stream :end n)))))))
1159      (let* ((statusflags (check-pid (external-process-pid p)
1160                                     (logior
1161                                      (if in-fd #$WNOHANG 0)
1162                                      #$WUNTRACED)))
1163             (oldstatus (external-process-%status p)))
1164        (cond ((null statusflags)
1165               (remove-external-process p)
1166               (setq terminated t))
1167              ((eq statusflags t))      ; Running.
1168              (t
1169               (multiple-value-bind (status code core)
1170                   (cond ((wifstopped statusflags)
1171                          (values :stopped (wstopsig statusflags)))
1172                         ((wifexited statusflags)
1173                          (values :exited (wexitstatus statusflags)))
1174                         (t
1175                          (let* ((signal (wtermsig statusflags)))
1176                            (declare (fixnum signal))
1177                            (values
1178                             (if (or (= signal #$SIGSTOP)
1179                                     (= signal #$SIGTSTP)
1180                                     (= signal #$SIGTTIN)
1181                                     (= signal #$SIGTTOU))
1182                               :stopped
1183                               :signaled)
1184                             signal
1185                             (logtest #-solaris-target #$WCOREFLAG
1186                                      #+solaris-target #$WCOREFLG
1187                                      statusflags)))))
1188                 (setf (external-process-%status p) status
1189                       (external-process-%exit-code p) code
1190                       (external-process-core p) core)
1191                 (let* ((status-hook (external-process-status-hook p)))
1192                   (when (and status-hook (not (eq oldstatus status)))
1193                     (funcall status-hook p)))
1194                 (when (or (eq status :exited)
1195                           (eq status :signaled))
1196                   (remove-external-process p)
1197                   (setq terminated t)))))))))
1198     
1199(defun run-external-process (proc in-fd out-fd error-fd &optional env)
1200  ;; type-check the env variable
1201  (dolist (pair env)
1202    (destructuring-bind (var . val) pair
1203      (assert (typep var '(or string symbol character)))
1204      (assert (typep val 'string)))) 
1205  (call-with-string-vector
1206   #'(lambda (argv)
1207       (let* ((child-pid (#_fork)))
1208         (declare (fixnum child-pid))
1209         (cond ((zerop child-pid)
1210                ;; Running in the child; do an exec
1211                (dolist (pair env)
1212                  (setenv (string (car pair)) (cdr pair)))
1213                (without-interrupts
1214                 (exec-with-io-redirection
1215                  in-fd out-fd error-fd argv)))
1216               ((> child-pid 0)
1217                ;; Running in the parent: success
1218                (setf (external-process-pid proc) child-pid)
1219                (add-external-process proc)
1220                (signal-semaphore (external-process-signal proc))
1221                (monitor-external-process proc))
1222               (t
1223                ;; Fork failed
1224                (setf (external-process-%status proc) :error
1225                      (external-process-%exit-code proc) (%get-errno))
1226                (signal-semaphore (external-process-signal proc))))))
1227   (external-process-args proc)))
1228
1229               
1230(defun run-program (program args &key
1231                            (wait t) pty
1232                            input if-input-does-not-exist
1233                            output (if-output-exists :error)
1234                            (error :output) (if-error-exists :error)
1235                            status-hook (element-type 'character)
1236                            env)
1237  "Invoke an external program as an OS subprocess of lisp."
1238  (declare (ignore pty))
1239  (unless (every #'(lambda (a) (typep a 'simple-string)) args)
1240    (error "Program args must all be simple strings : ~s" args))
1241  (push (native-untranslated-namestring program) args)
1242  (let* ((token (list 0))
1243         (in-fd nil)
1244         (in-stream nil)
1245         (out-fd nil)
1246         (out-stream nil)
1247         (error-fd nil)
1248         (error-stream nil)
1249         (close-in-parent nil)
1250         (close-on-error nil)
1251         (proc
1252          (make-external-process
1253           :pid nil
1254           :args args
1255           :%status :running
1256           :input nil
1257           :output nil
1258           :error nil
1259           :token token
1260           :status-hook status-hook)))
1261    (unwind-protect
1262         (progn
1263           (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
1264             (get-descriptor-for input proc  nil nil :direction :input
1265                                 :if-does-not-exist if-input-does-not-exist
1266                                 :element-type element-type))
1267           (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
1268             (get-descriptor-for output proc close-in-parent close-on-error
1269                                 :direction :output
1270                                 :if-exists if-output-exists
1271                                 :element-type element-type))
1272           (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
1273             (if (eq error :output)
1274               (values out-fd out-stream close-in-parent close-on-error)
1275               (get-descriptor-for error proc close-in-parent close-on-error
1276                                   :direction :output
1277                                   :if-exists if-error-exists
1278                                   :element-type element-type)))
1279           (setf (external-process-input proc) in-stream
1280                 (external-process-output proc) out-stream
1281                 (external-process-error proc) error-stream)
1282           (process-run-function
1283            (list :name
1284                  (format nil "Monitor thread for external process ~a" args)
1285                  :stack-size (ash 128 10)
1286                  :vstack-size (ash 128 10)
1287                  :tstack-size (ash 128 10))
1288            #'run-external-process proc in-fd out-fd error-fd env)
1289           (wait-on-semaphore (external-process-signal proc))
1290           )
1291      (dolist (fd close-in-parent) (fd-close fd))
1292      (unless (external-process-pid proc)
1293        (dolist (fd close-on-error) (fd-close fd)))
1294      (when (and wait (external-process-pid proc))
1295        (with-interrupts-enabled
1296            (wait-on-semaphore (external-process-completed proc)))))
1297    (and (or (external-process-pid proc)
1298             (if (eq (external-process-%status proc) :error)
1299               (error "Fork failed in ~s: ~s" proc (%strerror (external-process-%exit-code proc)))))
1300             (external-process-%status proc)) proc))
1301
1302
1303
1304
1305(defmacro wifsignaled (status)
1306  (let* ((statname (gensym)))
1307    `(let* ((,statname ,status))
1308      (and (not (wifstopped ,statname)) (not (wifexited ,statname))))))
1309
1310
1311(defun check-pid (pid &optional (flags (logior  #$WNOHANG #$WUNTRACED)))
1312  (declare (fixnum pid))
1313  (rlet ((status :signed))
1314    (let* ((retval (ff-call-ignoring-eintr (#_waitpid pid status flags))))
1315      (declare (fixnum retval))
1316      (if (= retval pid)
1317        (pref status :signed)
1318        (zerop retval)))))
1319
1320
1321
1322
1323
1324(defun external-process-wait (proc &optional check-stopped)
1325  (process-wait "external-process-wait"
1326                #'(lambda ()
1327                    (case (external-process-%status proc)
1328                      (:running)
1329                      (:stopped
1330                       (when check-stopped
1331                         t))
1332                      (t
1333                       (when (zerop (car (external-process-token proc)))
1334                         t))))))
1335
1336(defun external-process-status (proc)
1337  "Return information about whether an OS subprocess is running; or, if
1338not, why not; and what its result code was if it completed."
1339  (require-type proc 'external-process)
1340  (values (external-process-%status proc)
1341          (external-process-%exit-code proc)))
1342
1343(defun external-process-input-stream (proc)
1344  "Return the lisp stream which is used to write input to a given OS
1345subprocess, if it has one."
1346  (require-type proc 'external-process)
1347  (external-process-input proc))
1348
1349(defun external-process-output-stream (proc)
1350  "Return the lisp stream which is used to read output from a given OS
1351subprocess, if there is one."
1352  (require-type proc 'external-process)
1353  (external-process-output proc))
1354
1355(defun external-process-error-stream (proc)
1356  "Return the stream which is used to read error output from a given OS
1357subprocess, if it has one."
1358  (require-type proc 'external-process)
1359  (external-process-error proc))
1360
1361(defun external-process-id (proc)
1362  "Return the process id of an OS subprocess, a positive integer which
1363identifies it."
1364  (require-type proc 'external-process)
1365  (external-process-pid proc))
1366 
1367(defun signal-external-process (proc signal)
1368  "Send the specified signal to the specified external process.  (Typically,
1369it would only be useful to call this function if the EXTERNAL-PROCESS was
1370created with :WAIT NIL.) Return T if successful; signal an error otherwise."
1371  (require-type proc 'external-process)
1372  (let* ((pid (external-process-pid proc)))
1373    (when pid
1374      (int-errno-call (#_kill pid signal)))))
1375
1376) ; #-windows-target (progn
1377
1378#+windows-target
1379(progn
1380(defun temp-file-name (prefix)
1381  "Returns a unique name for a temporary file, residing in system temp
1382space, and prefixed with PREFIX."
1383  (rlet ((buffer (:array :wchar_t #.#$MAX_PATH)))
1384    (#_GetTempPathW #$MAX_PATH buffer)
1385    (with-filename-cstrs ((c-prefix prefix)) 
1386      (#_GetTempFileNameW buffer c-prefix 0 buffer)
1387      (%get-native-utf-16-cstring buffer))))
1388 
1389(defun get-descriptor-for (object proc close-in-parent close-on-error
1390                                  &rest keys &key direction (element-type 'character)
1391                                  &allow-other-keys)
1392  (etypecase object
1393    ((eql t)
1394     (values nil nil close-in-parent close-on-error))
1395    (null
1396     (let* ((null-device "nul")
1397            (fd (fd-open null-device (case direction
1398                                       (:input #$O_RDONLY)
1399                                       (:output #$O_WRONLY)
1400                                       (t #$O_RDWR)))))
1401       (if (< fd 0)
1402         (signal-file-error fd null-device))
1403       (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
1404    ((eql :stream)
1405     (multiple-value-bind (read-pipe write-pipe) (pipe)
1406       (case direction
1407         (:input
1408          (values read-pipe
1409                  (make-fd-stream (fd-uninheritable write-pipe :direction :output)
1410                                  :direction :output
1411                                  :element-type element-type
1412                                  :interactive nil
1413                                  :basic t
1414                                  :auto-close t)
1415                  (cons read-pipe close-in-parent)
1416                  (cons write-pipe close-on-error)))
1417         (:output
1418          (values write-pipe
1419                  (make-fd-stream (fd-uninheritable read-pipe :direction :input)
1420                                  :direction :input
1421                                  :element-type element-type
1422                                  :interactive nil
1423                                  :basic t
1424                                  :auto-close t)
1425                  (cons write-pipe close-in-parent)
1426                  (cons read-pipe close-on-error)))
1427         (t
1428          (fd-close read-pipe)
1429          (fd-close write-pipe)
1430          (report-bad-arg direction '(member :input :output))))))
1431    ((or pathname string)
1432     (with-open-stream (file (apply #'open object keys))
1433       (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)) :direction direction :inheritable t)))
1434         (values fd
1435                 nil
1436                 (cons fd close-in-parent)
1437                 (cons fd close-on-error)))))
1438    (fd-stream
1439     (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
1440       (values fd
1441               nil
1442               (cons fd close-in-parent)
1443               (cons fd close-on-error))))
1444    (stream
1445     (ecase direction
1446       (:input
1447        (let* ((tempname (temp-file-name "lisp-temp"))
1448               (fd (fd-open tempname #$O_RDWR)))
1449          (if (< fd 0)
1450            (%errno-disp fd))
1451          (loop
1452            (multiple-value-bind (line no-newline)
1453                (read-line object nil nil)
1454              (unless line
1455                (return))
1456              (let* ((len (length line)))
1457                (%stack-block ((buf (1+ len)))
1458                  (%cstr-pointer line buf)
1459                  (fd-write fd buf len)
1460                  (if no-newline
1461                    (return))
1462                  (setf (%get-byte buf) (char-code #\newline))
1463                  (fd-write fd buf 1)))))
1464          (fd-lseek fd 0 #$SEEK_SET)
1465          (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
1466       (:output
1467        (multiple-value-bind (read-pipe write-pipe) (pipe)
1468          (setf (external-process-watched-fd proc) read-pipe
1469                (external-process-watched-stream proc) object)
1470          (incf (car (external-process-token proc)))
1471          (values write-pipe
1472                  nil
1473                  (cons write-pipe close-in-parent)
1474                  (cons read-pipe close-on-error))))))))
1475
1476(defstruct external-process
1477  pid
1478  %status
1479  %exit-code
1480  pty
1481  input
1482  output
1483  error
1484  status-hook
1485  plist
1486  token
1487  core
1488  args
1489  (signal (make-semaphore))
1490  (completed (make-semaphore))
1491  watched-fd
1492  watched-stream
1493  )
1494
1495(defun external-process-status (proc)
1496  "Return information about whether an OS subprocess is running; or, if
1497not, why not; and what its result code was if it completed."
1498  (require-type proc 'external-process)
1499  (values (external-process-%status proc)
1500          (external-process-%exit-code proc)))
1501
1502
1503(defmethod print-object ((p external-process) stream)
1504  (print-unreadable-object (p stream :type t :identity t)
1505    (let* ((status (external-process-%status p)))
1506      (let* ((*print-length* 3))
1507        (format stream "~a" (external-process-args p)))
1508      (format stream "[~d] (~a" (external-process-pid p) status)
1509      (unless (eq status :running)
1510        (format stream " : ~d" (external-process-%exit-code p)))
1511      (format stream ")"))))
1512
1513(defun run-program (program args &key
1514                            (wait t) pty
1515                            input if-input-does-not-exist
1516                            output (if-output-exists :error)
1517                            (error :output) (if-error-exists :error)
1518                            status-hook (element-type 'character)
1519                            env)
1520  "Invoke an external program as an OS subprocess of lisp."
1521  (declare (ignore pty))
1522  (unless (every #'(lambda (a) (typep a 'simple-string)) args)
1523    (error "Program args must all be simple strings : ~s" args))
1524  (push program args)
1525  (let* ((token (list 0))
1526         (in-fd nil)
1527         (in-stream nil)
1528         (out-fd nil)
1529         (out-stream nil)
1530         (error-fd nil)
1531         (error-stream nil)
1532         (close-in-parent nil)
1533         (close-on-error nil)
1534         (proc
1535          (make-external-process
1536           :pid nil
1537           :args args
1538           :%status :running
1539           :input nil
1540           :output nil
1541           :error nil
1542           :token token
1543           :status-hook status-hook)))
1544    (unwind-protect
1545         (progn
1546           (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
1547             (get-descriptor-for input proc  nil nil :direction :input
1548                                 :if-does-not-exist if-input-does-not-exist
1549                                 :element-type element-type))
1550           (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
1551             (get-descriptor-for output proc close-in-parent close-on-error
1552                                 :direction :output
1553                                 :if-exists if-output-exists
1554                                 :element-type element-type))
1555           (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
1556             (if (eq error :output)
1557               (values out-fd out-stream close-in-parent close-on-error)
1558               (get-descriptor-for error proc close-in-parent close-on-error
1559                                   :direction :output
1560                                   :if-exists if-error-exists
1561                                   :element-type element-type)))
1562           (setf (external-process-input proc) in-stream
1563                 (external-process-output proc) out-stream
1564                 (external-process-error proc) error-stream)
1565           (process-run-function
1566            (format nil "Monitor thread for external process ~a" args)
1567                   
1568            #'run-external-process proc in-fd out-fd error-fd env)
1569           (wait-on-semaphore (external-process-signal proc))
1570           )
1571      (dolist (fd close-in-parent) (fd-close fd))
1572      (if (external-process-pid proc)
1573        (when (and wait (external-process-pid proc))
1574          (with-interrupts-enabled
1575              (wait-on-semaphore (external-process-completed proc))))
1576        (progn
1577          (dolist (fd close-on-error) (fd-close fd))
1578          (error "Process execution failed"))))
1579    proc))
1580
1581(let* ((external-processes ())
1582       (external-processes-lock (make-lock)))
1583  (defun add-external-process (p)
1584    (with-lock-grabbed (external-processes-lock)
1585      (push p external-processes)))
1586  (defun remove-external-process (p)
1587    (with-lock-grabbed (external-processes-lock)
1588      (setq external-processes (delete p external-processes))))
1589  ;; Likewise
1590  (defun external-processes ()
1591    (with-lock-grabbed (external-processes-lock)
1592      (copy-list external-processes)))
1593  )
1594
1595
1596
1597
1598(defun run-external-process (proc in-fd out-fd error-fd &optional env)
1599  (let* ((args (external-process-args proc))
1600         (child-pid (exec-with-io-redirection in-fd out-fd error-fd args proc env)))
1601    (when child-pid
1602      (setf (external-process-pid proc) child-pid)
1603      (add-external-process proc)
1604      (signal-semaphore (external-process-signal proc))
1605      (monitor-external-process proc))))
1606
1607(defun join-strings (strings)
1608  (reduce (lambda (left right) (concatenate 'string left " " right)) strings))
1609
1610(defun exec-with-io-redirection (new-in new-out new-err args proc &optional env)
1611  (declare (ignore env))                ; until we can do better.
1612  (with-filename-cstrs ((command (join-strings args)))
1613    (rletz ((proc-info #>PROCESS_INFORMATION)
1614            (si #>STARTUPINFO))
1615      (setf (pref si #>STARTUPINFO.cb) (record-length #>STARTUPINFO))
1616      (setf (pref si #>STARTUPINFO.dwFlags)
1617            (logior #$STARTF_USESTDHANDLES #$STARTF_USESHOWWINDOW))
1618      (setf (pref si #>STARTUPINFO.wShowWindow) #$SW_HIDE)
1619      (setf (pref si #>STARTUPINFO.hStdInput)
1620            (if new-in
1621              (%int-to-ptr new-in)
1622              (#_GetStdHandle #$STD_INPUT_HANDLE)))
1623      (setf (pref si #>STARTUPINFO.hStdOutput)
1624            (if new-out
1625              (%int-to-ptr new-out)
1626              (#_GetStdHandle #$STD_OUTPUT_HANDLE)))
1627      (setf (pref si #>STARTUPINFO.hStdError)
1628            (if new-err
1629              (%int-to-ptr new-err)
1630              (#_GetStdHandle #$STD_ERROR_HANDLE)))
1631      (if (zerop (#_CreateProcessW (%null-ptr)
1632                                   command
1633                                   (%null-ptr)
1634                                   (%null-ptr)
1635                                   1
1636                                   #$CREATE_NEW_CONSOLE
1637                                   (%null-ptr)
1638                                   (%null-ptr)
1639                                   si
1640                                   proc-info))
1641        (setf (external-process-%status proc) :error
1642              (external-process-%exit-code proc) (#_GetLastError))
1643        (#_CloseHandle (pref proc-info #>PROCESS_INFORMATION.hThread)))
1644      (pref proc-info #>PROCESS_INFORMATION.hProcess))))
1645
1646(defun fd-uninheritable (fd &key direction)
1647  (let ((new-fd (fd-dup fd :direction direction)))
1648    (fd-close fd)
1649    new-fd))
1650
1651(defun monitor-external-process (p)
1652  (let* ((in-fd (external-process-watched-fd p))
1653         (out-stream (external-process-watched-stream p))
1654         (token (external-process-token p))
1655         (terminated))
1656    (loop
1657      (when terminated
1658        (without-interrupts
1659         (decf (car token))
1660         (if in-fd (fd-close in-fd))
1661         (setq in-fd nil)
1662         (rlet ((code #>DWORD))
1663           (loop
1664             (#_GetExitCodeProcess (external-process-pid p) code)
1665             (unless (eql (pref code #>DWORD) #$STILL_ACTIVE)
1666               (return)))
1667           (#_SleepEx 10 #$TRUE)
1668           (setf (external-process-%exit-code p) (pref code #>DWORD)))
1669         (#_CloseHandle (external-process-pid p))
1670         (setf (external-process-pid p) nil)
1671         (setf (external-process-%status p) :exited)
1672         (let ((status-hook (external-process-status-hook p)))
1673           (when status-hook
1674             (funcall status-hook p)))
1675         (remove-external-process p)
1676         (signal-semaphore (external-process-completed p))
1677         (return)))     
1678      (if in-fd
1679        (rlet ((handles (:array #>HANDLE 2)))
1680          (setf (paref handles (:array #>HANDLE) 0) (external-process-pid p))
1681          (setf (paref handles (:array #>HANDLE) 1) (#__get_osfhandle in-fd))
1682          (let ((rc (ignoring-eintr
1683                     (let* ((code (#_WaitForMultipleObjectsEx 2 handles #$FALSE #$INFINITE #$true)))
1684                       (if (eql code #$WAIT_IO_COMPLETION)
1685                         (- #$EINTR)
1686                         code)))))
1687            (if (eq rc #$WAIT_OBJECT_0)
1688              (setf terminated t)
1689              (%stack-block ((buf 1024))
1690                (let* ((n (fd-read in-fd buf 1024)))
1691                  (declare (fixnum n))
1692                  (if (<= n 0)
1693                    (setf terminated t)
1694                    (let* ((string (make-string 1024)))
1695                      (declare (dynamic-extent string))
1696                      (%str-from-ptr buf n string)
1697                      (write-sequence string out-stream :end n))))))))
1698        (progn
1699          (ignoring-eintr
1700           (let* ((code (#_WaitForSingleObjectEx (external-process-pid p) #$INFINITE #$true)))
1701             (if (eql code #$WAIT_IO_COMPLETION)
1702               (- #$EINTR)
1703               code)))
1704          (setf terminated t))))))
1705 
1706
1707)                                   ; #+windows-target (progn
1708
1709;;; EOF on a TTY is transient, but I'm less sure of other cases.
1710(defun eof-transient-p (fd)
1711  (case (%unix-fd-kind fd)
1712    (:tty t)
1713    #+windows-target (:character-special t)
1714    (t nil)))
1715
1716
1717(defstruct (shared-resource (:constructor make-shared-resource (name)))
1718  (name)
1719  (lock (make-lock))
1720  (primary-owner *current-process*)
1721  (primary-owner-notify (make-semaphore))
1722  (current-owner nil)
1723  (requestors (make-dll-header)))
1724
1725(defstruct (shared-resource-request
1726             (:constructor make-shared-resource-request (process))
1727             (:include dll-node))
1728  process
1729  (signal (make-semaphore)))
1730             
1731
1732;; Returns NIL if already owned by calling thread, T otherwise
1733(defun %acquire-shared-resource (resource  &optional verbose)
1734  (let* ((current *current-process*))
1735    (with-lock-grabbed ((shared-resource-lock resource))
1736      (let* ((secondary (shared-resource-current-owner resource)))
1737        (if (or (eq current secondary)
1738                (and (null secondary)
1739                     (eq current (shared-resource-primary-owner resource))))
1740          (return-from %acquire-shared-resource nil))))
1741    (let* ((request (make-shared-resource-request *current-process*)))
1742      (when verbose
1743        (format t "~%~%;;;~%;;; ~a requires access to ~a~%;;;~%~%"
1744                *current-process* (shared-resource-name resource)))
1745      (with-lock-grabbed ((shared-resource-lock resource))
1746        (append-dll-node request (shared-resource-requestors resource)))
1747      (wait-on-semaphore (shared-resource-request-signal request))
1748      (assert (eq current (shared-resource-current-owner resource)))
1749      (when verbose
1750        (format t "~%~%;;;~%;;; ~a is now owned by ~a~%;;;~%~%"
1751                (shared-resource-name resource) current))
1752      t)))
1753
1754;;; If we're the primary owner and there is no secondary owner, do nothing.
1755;;; If we're the secondary owner, cease being the secondary owner.
1756(defun %release-shared-resource (r)
1757  (let* ((not-any-owner ()))
1758    (with-lock-grabbed ((shared-resource-lock r))
1759      (let* ((current *current-process*)
1760             (primary (shared-resource-primary-owner r))
1761             (secondary (shared-resource-current-owner r)))
1762        (unless (setq not-any-owner
1763                      (not (or (eq current secondary)
1764                               (and (null secondary)
1765                                    (eq current primary)))))
1766          (when (eq current secondary)
1767            (setf (shared-resource-current-owner r) nil)
1768            (signal-semaphore (shared-resource-primary-owner-notify r))))))
1769    (when not-any-owner
1770      (signal-program-error "Process ~a does not own ~a" *current-process*
1771                            (shared-resource-name r)))))
1772
1773;;; The current thread should be the primary owner; there should be
1774;;; no secondary owner.  Wakeup the specified (or first) requesting
1775;;; process, then block on our semaphore
1776(defun %yield-shared-resource (r &optional to)
1777  (let* ((request nil))
1778    (with-lock-grabbed ((shared-resource-lock r))
1779      (let* ((current *current-process*)
1780             (primary (shared-resource-primary-owner r)))
1781        (when (and (eq current primary)
1782                   (null (shared-resource-current-owner r)))
1783          (setq request
1784                (let* ((header (shared-resource-requestors r)))
1785                  (if to 
1786                    (do-dll-nodes (node header)
1787                      (when (eq to (shared-resource-request-process node))
1788                        (return node)))
1789                    (let* ((first (dll-header-first header)))
1790                      (unless (eq first header)
1791                        first)))))
1792          (when request
1793            (remove-dll-node request)
1794            (setf (shared-resource-current-owner r)
1795                  (shared-resource-request-process request))
1796            (signal-semaphore (shared-resource-request-signal request))))))
1797    (when request
1798      (wait-on-semaphore (shared-resource-primary-owner-notify r))
1799      (format t "~%;;;~%;;;control of ~a restored to ~a~%;;;~&"
1800              (shared-resource-name r)
1801              *current-process*))))
1802
1803
1804     
1805
1806(defun %shared-resource-requestor-p (r proc)
1807  (with-lock-grabbed ((shared-resource-lock r))
1808    (do-dll-nodes (node (shared-resource-requestors r))
1809      (when (eq proc (shared-resource-request-process node))
1810        (return t)))))
1811
1812(defparameter *resident-editor-hook* nil
1813  "If non-NIL, should be a function that takes an optional argument
1814   (like ED) and invokes a \"resident\" editor.")
1815
1816(defun ed (&optional arg)
1817  (if *resident-editor-hook*
1818    (funcall *resident-editor-hook* arg)
1819    (error "This implementation doesn't provide a resident editor.")))
1820
1821(defun running-under-emacs-p ()
1822  (not (null (getenv "EMACS"))))
1823
1824(defloadvar *cpu-count* nil)
1825
1826(defun cpu-count ()
1827  (or *cpu-count*
1828      (setq *cpu-count*
1829            #+darwin-target
1830            (rlet ((info :host_basic_info)
1831                   (count :mach_msg_type_number_t #$HOST_BASIC_INFO_COUNT))
1832              (if (eql #$KERN_SUCCESS (#_host_info (#_mach_host_self)
1833                                                   #$HOST_BASIC_INFO
1834                                                   info
1835                                                   count))
1836                (pref info :host_basic_info.max_cpus)
1837                1))
1838            #+(or linux-target solaris-target)
1839            (or
1840             (let* ((n (#_sysconf #$_SC_NPROCESSORS_ONLN)))
1841               (declare (fixnum n))
1842               (if (> n 0) n))
1843             #+linux-target
1844             (ignore-errors
1845               (with-open-file (p "/proc/cpuinfo")
1846                 (let* ((ncpu 0)
1847                        (match "processor")
1848                        (matchlen (length match)))
1849                   (do* ((line (read-line p nil nil) (read-line p nil nil)))
1850                        ((null line) ncpu)
1851                     (let* ((line-length (length line)))
1852                       (when (and
1853                              (> line-length matchlen)
1854                              (string= match line
1855                                       :end2 matchlen)
1856                              (whitespacep (schar line matchlen)))
1857                         (incf ncpu)))))))
1858             1)
1859            #+freebsd-target
1860            (rlet ((ret :uint))
1861              (%stack-block ((mib (* (record-length :uint) 2)))
1862              (setf (paref mib (:array :uint) 0)
1863                    #$CTL_HW
1864                    (paref mib (:array :uint) 1)
1865                    #$HW_NCPU)
1866              (rlet ((oldsize :uint (record-length :uint)))
1867                (if (eql 0 (#_sysctl mib 2 ret oldsize (%null-ptr) 0))
1868                  (pref ret :uint)
1869                  1))))
1870            #+windows-target
1871            (rlet ((procmask #>DWORD_PTR)
1872                   (sysmask #>DWORD_PTR))
1873              (if (eql 0 (#_GetProcessAffinityMask (#_GetCurrentProcess) procmask sysmask))
1874                1
1875                (logcount (pref sysmask #>DWORD_PTR)))))))
1876
1877(def-load-pointers spin-count ()
1878  (if (eql 1 (cpu-count))
1879    (%defglobal '*spin-lock-tries* 1)
1880    (%defglobal '*spin-lock-tries* 1024))
1881  (%defglobal '*spin-lock-timeouts* 0))
1882
1883(defun yield ()
1884  #+windows-target
1885  (#_Sleep 0)
1886  #-windows-target 
1887  (#_sched_yield))
1888
1889(defloadvar *host-page-size*
1890    #-windows-target (#_getpagesize)
1891    #+windows-target
1892    (rlet ((info #>SYSTEM_INFO))
1893      (#_GetSystemInfo info)
1894      (pref info #>SYSTEM_INFO.dwPageSize))
1895    )
1896
1897;;(assert (= (logcount *host-page-size*) 1))
1898
1899(defun get-universal-time ()
1900  "Return a single integer for the current time of
1901   day in universal time format."
1902  (rlet ((tv :timeval))
1903    (gettimeofday tv)
1904    (+ (pref tv :timeval.tv_sec) unix-to-universal-time)))
1905
1906#-windows-target
1907(progn
1908(defun map-file-to-ivector (pathname element-type)
1909  (let* ((upgraded-type (upgraded-array-element-type element-type))
1910         (upgraded-ctype (specifier-type upgraded-type)))
1911    (unless (and (typep upgraded-ctype 'numeric-ctype)
1912                 (eq 'integer (numeric-ctype-class upgraded-ctype)))
1913      (error "Invalid element-type: ~s" element-type))
1914    (let* ((bits-per-element (integer-length (- (numeric-ctype-high upgraded-ctype)
1915                                                (numeric-ctype-low upgraded-ctype))))
1916           (fd (fd-open (native-translated-namestring pathname) #$O_RDONLY)))
1917      (if (< fd 0)
1918        (signal-file-error fd pathname)
1919        (let* ((len (fd-size fd)))
1920          (if (< len 0)
1921            (signal-file-error fd pathname)
1922            (let* ((nbytes (+ *host-page-size*
1923                              (logandc2 (+ len
1924                                           (1- *host-page-size*))
1925                                        (1- *host-page-size*))))
1926
1927                   (ndata-elements
1928                    (ash len
1929                         (ecase bits-per-element
1930                           (1 3)
1931                           (8 0)
1932                           (16 -1)
1933                           (32 -2)
1934                           (64 -3))))
1935                   (nalignment-elements
1936                    (ash target::nbits-in-word
1937                         (ecase bits-per-element
1938                           (1 0)
1939                           (8 -3)
1940                           (16 -4)
1941                           (32 -5)
1942                           (64 -6)))))
1943              (if (>= (+ ndata-elements nalignment-elements)
1944                      array-total-size-limit)
1945                (progn
1946                  (fd-close fd)
1947                  (error "Can't make a vector with ~s elements in this implementation." (+ ndata-elements nalignment-elements)))
1948                (let* ((addr (#_mmap (%null-ptr)
1949                                     nbytes
1950                                     #$PROT_NONE
1951                                     (logior #$MAP_ANON #$MAP_PRIVATE)
1952                                     -1
1953                                     0)))             
1954                  (if (eql addr (%int-to-ptr (1- (ash 1 target::nbits-in-word)))) ; #$MAP_FAILED
1955                    (let* ((errno (%get-errno)))
1956                      (fd-close fd)
1957                      (error "Can't map ~d bytes: ~a" nbytes (%strerror errno)))
1958              ;;; Remap the first page so that we can put a vector header
1959              ;;; there; use the first word on the first page to remember
1960              ;;; the file descriptor.
1961                    (progn
1962                      (#_mmap addr
1963                              *host-page-size*
1964                              (logior #$PROT_READ #$PROT_WRITE)
1965                              (logior #$MAP_ANON #$MAP_PRIVATE #$MAP_FIXED)
1966                              -1
1967                              0)
1968                      (setf (pref addr :int) fd)
1969                      (let* ((header-addr (%inc-ptr addr (- *host-page-size*
1970                                                            (* 2 target::node-size)))))
1971                        (setf (pref header-addr :unsigned-long)
1972                              (logior (element-type-subtype upgraded-type)
1973                                      (ash (+ ndata-elements nalignment-elements) target::num-subtag-bits)))
1974                        (when (> len 0)
1975                          (let* ((target-addr (%inc-ptr header-addr (* 2 target::node-size))))
1976                            (unless (eql target-addr
1977                                         (#_mmap target-addr
1978                                                 len
1979                                                 #$PROT_READ
1980                                                 (logior #$MAP_PRIVATE #$MAP_FIXED)
1981                                                 fd
1982                                                 0))
1983                              (let* ((errno (%get-errno)))
1984                                (fd-close fd)
1985                                (#_munmap addr nbytes)
1986                                (error "Mapping failed: ~a" (%strerror errno))))))
1987                        (with-macptrs ((v (%inc-ptr header-addr target::fulltag-misc)))
1988                          (let* ((vector (rlet ((p :address v)) (%get-object p 0))))
1989                            ;; Tell some parts of OpenMCL - notably the
1990                            ;; printer - that this thing off in foreign
1991                            ;; memory is a real lisp object and not
1992                            ;; "bogus".
1993                            (with-lock-grabbed (*heap-ivector-lock*)
1994                              (push vector *heap-ivectors*))
1995                            (make-array ndata-elements
1996                                        :element-type upgraded-type
1997                                        :displaced-to vector
1998                                        :adjustable t
1999                                        :displaced-index-offset nalignment-elements)))))))))))))))
2000
2001(defun map-file-to-octet-vector (pathname)
2002  (map-file-to-ivector pathname '(unsigned-byte 8)))
2003
2004(defun mapped-vector-data-address-and-size (displaced-vector)
2005  (let* ((v (array-displacement displaced-vector))
2006         (element-type (array-element-type displaced-vector)))
2007    (if (or (eq v displaced-vector)
2008            (not (with-lock-grabbed (*heap-ivector-lock*)
2009                   (member v *heap-ivectors*))))
2010      (error "~s doesn't seem to have been allocated via ~s and not yet unmapped" displaced-vector 'map-file-to-ivector))
2011    (let* ((pv (rlet ((x :address)) (%set-object x 0 v) (pref x :address)))
2012           (ctype (specifier-type element-type))
2013           (arch (backend-target-arch *target-backend*)))
2014      (values (%inc-ptr pv (- (* 2 target::node-size) target::fulltag-misc))
2015              (- (funcall (arch::target-array-data-size-function arch)
2016                          (ctype-subtype ctype)
2017                          (length v))
2018                 target::node-size)))))
2019
2020 
2021;;; Argument should be something returned by MAP-FILE-TO-IVECTOR;
2022;;; this should be called at most once for any such object.
2023(defun unmap-ivector (displaced-vector)
2024  (multiple-value-bind (data-address size-in-octets)
2025      (mapped-vector-data-address-and-size displaced-vector)
2026  (let* ((v (array-displacement displaced-vector))
2027         (base-address (%inc-ptr data-address (- *host-page-size*)))
2028         (fd (pref base-address :int)))
2029      (let* ((element-type (array-element-type displaced-vector)))
2030        (adjust-array displaced-vector 0
2031                      :element-type element-type
2032                      :displaced-to (make-array 0 :element-type element-type)
2033                      :displaced-index-offset 0))
2034      (with-lock-grabbed (*heap-ivector-lock*)
2035        (setq *heap-ivectors* (delete v *heap-ivectors*)))
2036      (#_munmap base-address (+ size-in-octets *host-page-size*))     
2037      (fd-close fd)
2038      t)))
2039
2040(defun unmap-octet-vector (v)
2041  (unmap-ivector v))
2042
2043(defun lock-mapped-vector (v)
2044  (multiple-value-bind (address nbytes)
2045      (mapped-vector-data-address-and-size v)
2046    (eql 0 (#_mlock address nbytes))))
2047
2048(defun unlock-mapped-vector (v)
2049  (multiple-value-bind (address nbytes)
2050      (mapped-vector-data-address-and-size v)
2051    (eql 0 (#_munlock address nbytes))))
2052
2053(defun bitmap-for-mapped-range (address nbytes)
2054  (let* ((npages (ceiling nbytes *host-page-size*)))
2055    (%stack-block ((vec npages))
2056      (when (eql 0 (#_mincore address nbytes vec))
2057        (let* ((bits (make-array npages :element-type 'bit)))
2058          (dotimes (i npages bits)
2059            (setf (sbit bits i)
2060                  (logand 1 (%get-unsigned-byte vec i)))))))))
2061
2062(defun percentage-of-resident-pages (address nbytes)
2063  (let* ((npages (ceiling nbytes *host-page-size*)))
2064    (%stack-block ((vec npages))
2065      (when (eql 0 (#_mincore address nbytes vec))
2066        (let* ((nresident 0))
2067          (dotimes (i npages (* 100.0 (/ nresident npages)))
2068            (when (logbitp 0 (%get-unsigned-byte vec i))
2069              (incf nresident))))))))
2070
2071(defun mapped-vector-resident-pages (v)
2072  (multiple-value-bind (address nbytes)
2073      (mapped-vector-data-address-and-size v)
2074    (bitmap-for-mapped-range address nbytes)))
2075
2076(defun mapped-vector-resident-pages-percentage (v)
2077  (multiple-value-bind (address nbytes)
2078      (mapped-vector-data-address-and-size v)
2079    (percentage-of-resident-pages address nbytes)))
2080)
2081
2082#+windows-target
2083(defun cygpath (winpath)
2084  "Try to use the Cygwin \"cygpath\" program to map a Windows-style
2085   pathname to a POSIX-stype Cygwin pathname."
2086  (let* ((posix-path winpath))
2087    (with-output-to-string (s)
2088      (multiple-value-bind (status exit-code)
2089          (external-process-status
2090           (run-program "cygpath" (list "-u" winpath) :output s))
2091        (when (and (eq status :exited)
2092                   (eql exit-code 0))
2093          (with-input-from-string (output (get-output-stream-string s))
2094            (setq posix-path (read-line output nil nil))))))
2095    posix-path))
2096
2097#-windows-target (defun cygpath (path) path)
2098     
2099
2100
2101
2102#+x86-target
2103(progn
2104(defloadvar *last-rdtsc-time* 0)
2105
2106(defstatic *rdtsc-estimated-increment* 1 "Should be positive ...")
2107
2108(defun rdtsc-monotonic ()
2109  "Return monotonically increasing values, partly compensating for
2110   OSes that don't keep the TSCs of all processorsin synch."
2111  (loop
2112    (let* ((old *last-rdtsc-time*)
2113           (new (rdtsc)))
2114      (when (< new old)
2115        ;; We're running on a CPU whose TSC is behind the one
2116        ;; on the last CPU we were scheduled on.
2117        (setq new (+ old *rdtsc-estimated-increment*)))
2118      (when (%store-node-conditional target::symbol.vcell *last-rdtsc-time* old new)
2119        (return new)))))
2120
2121(defun estimate-rdtsc-skew (&optional (niter 1000000))
2122  (do* ((i 0 (1+ i))
2123        (last (rdtsc) next)
2124        (next (rdtsc) (rdtsc))
2125        (skew 1))
2126       ((>= i niter) (setq *rdtsc-estimated-increment* skew))
2127    (declare (fixnum last next skew))
2128    (when (> last next)
2129      (let* ((s (- last next)))
2130        (declare (fixnum s))
2131        (when (> s skew) (setq skew s))))))
2132)
2133
2134
Note: See TracBrowser for help on using the repository browser.