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

Last change on this file since 11513 was 11513, checked in by gz, 11 years ago

fix monitor-external-process to not get confused when an fd is closed
with an output stream that is also used by another, unclosed, fd.

This made rebuild-ccl fail for me, every time, I don't understand why
it doesn't fail for others, but I think this change is correct in
any case.

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