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

Last change on this file since 11816 was 11816, checked in by gb, 10 years ago

Try to ensure that exported EXTERNAL-PROCESS functions are defined
unconditionally. (EXTERNAL-PROCESS-SIGNAL is exported; it's not
clear that it can do anything useful on Windows.)

If there's an error creating a process on Windows, set the status to
:ERROR and the exit code to the value returned by #_GetLastError, then
signal the semaphores; don't signal an error in the calling thread,
and don't wait for I/O in the background thread.

When copying process output to a lisp stream on Windows, filter
out #\Return characters. (Not exactly the same as turning CRLF
into LF, but easier and usually has the same effect.)

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