source: release/1.9/source/level-1/linux-files.lisp @ 15706

Last change on this file since 15706 was 15706, checked in by gb, 7 years ago

Propagate recent trunk changes.

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