source: branches/new-random/level-1/linux-files.lisp @ 13309

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

Separate OS-level file-mapping stuff from other file-mapping stuff,
provide implementations of MAP-FILE-TO-IVECTOR, UNMAP-IVECTOR, etc.
for Windows. Fixes ticket:627.

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