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

Last change on this file since 15609 was 15609, checked in by gb, 6 years ago

Fix UNSETENV for Windows. Export UNSETENV.

Change min image version for x8632, x8664.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 101.5 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 key))
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)
1076  (let ((bufsize (reduce #'+ strings
1077                         :key #'(lambda (s) (1+ (length (string s))))))
1078        (argvsize (ash (1+ (length strings)) target::word-shift))
1079        (bufpos 0)
1080        (argvpos 0))
1081    (%stack-block ((buf bufsize) (argv argvsize))
1082      (flet ((init (s)
1083             (multiple-value-bind (sstr start end) (get-sstring s)
1084               (declare (fixnum start end))
1085               (let ((len (- end start)))
1086                 (declare (fixnum len))
1087                 (do* ((i 0 (1+ i))
1088                       (start start (1+ start))
1089                       (bufpos bufpos (1+ bufpos)))
1090                      ((= i len))
1091                   (setf (%get-unsigned-byte buf bufpos)
1092                         (logand #xff (%scharcode sstr start))))
1093                 (setf (%get-byte buf (%i+ bufpos len)) 0)
1094                 (setf (%get-ptr argv argvpos) (%inc-ptr buf bufpos))
1095                 (setq bufpos (%i+ bufpos len 1))
1096                 (setq argvpos (%i+ argvpos target::node-size))))))
1097        (declare (dynamic-extent #'init))
1098        (map nil #'init strings))
1099      (setf (%get-ptr argv argvpos) (%null-ptr))
1100      (funcall function argv))))
1101
1102(defmacro with-string-vector ((var strings) &body body)
1103  `(call-with-string-vector #'(lambda (,var) ,@body) ,strings))
1104
1105(defloadvar *max-os-open-files* #-windows-target (#_getdtablesize) #+windows-target 32)
1106
1107(defun pipe ()
1108  ;;  (rlet ((filedes (:array :int 2)))
1109  (%stack-block ((filedes 8))
1110    (let* ((status (ff-call (%kernel-import target::kernel-import-lisp-pipe)
1111                            :address filedes :int))
1112           (errno (if (eql status 0) 0 (%get-errno))))
1113      (unless (zerop status)
1114        (when (or (eql errno (- #$EMFILE))
1115                  (eql errno (- #$ENFILE)))
1116          (gc)
1117          (drain-termination-queue)
1118          (setq status (ff-call (%kernel-import target::kernel-import-lisp-pipe)
1119                            :address filedes :int)
1120                errno (if (zerop status) 0 (%get-errno)))))
1121      (if (zerop status)
1122        (values (paref filedes (:array :int)  0) (paref filedes (:array :int)  1))
1123        (%errno-disp errno)))))
1124
1125#-windows-target
1126(progn
1127  (defun %execvp (argv)
1128    (#_execvp (%get-ptr argv) argv)
1129    (#_exit #-android-target #$EX_OSERR #+android-target 71))
1130
1131  (defun exec-with-io-redirection (new-in new-out new-err argv)
1132    (#_setpgid 0 0)
1133    (if new-in (#_dup2 new-in 0))
1134    (if new-out (#_dup2 new-out 1))
1135    (if new-err (#_dup2 new-err 2))
1136    (do* ((fd 3 (1+ fd)))
1137         ((= fd *max-os-open-files*) (%execvp argv))
1138      (declare (fixnum fd))
1139      (#_close fd)))
1140
1141
1142
1143
1144
1145  (defstruct external-process
1146    pid
1147    %status
1148    %exit-code
1149    pty
1150    input
1151    output
1152    error
1153    status-hook
1154    plist
1155    token                               
1156    core
1157    args
1158    (signal (make-semaphore))
1159    (completed (make-semaphore))
1160    watched-fds
1161    watched-streams
1162    external-format
1163    )
1164
1165  (defmethod print-object ((p external-process) stream)
1166    (print-unreadable-object (p stream :type t :identity t)
1167      (let* ((status (external-process-%status p)))
1168        (let* ((*print-length* 3))
1169          (format stream "~a" (external-process-args p)))
1170        (format stream "[~d] (~a" (external-process-pid p) status)
1171        (unless (eq status :running)
1172          (format stream " : ~d" (external-process-%exit-code p)))
1173        (format stream ")"))))
1174
1175  (defun get-descriptor-for (object proc close-in-parent close-on-error
1176                                    &rest keys
1177                                    &key direction (element-type 'character)
1178                                    (sharing :private)
1179                                    external-format
1180                                    &allow-other-keys)
1181    (etypecase object
1182      ((eql t)
1183       (values nil nil close-in-parent close-on-error))
1184      (null
1185       (let* ((null-device #+windows-target "nul" #-windows-target "/dev/null")
1186              (fd (fd-open null-device (case direction
1187                                         (:input #$O_RDONLY)
1188                                         (:output #$O_WRONLY)
1189                                         (t #$O_RDWR)))))
1190         (if (< fd 0)
1191           (signal-file-error fd null-device))
1192         (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
1193      ((eql :stream)
1194       (multiple-value-bind (read-pipe write-pipe) (pipe)
1195         (case direction
1196           (:input
1197            (values read-pipe
1198                    (make-fd-stream write-pipe
1199                                    :direction :output
1200                                    :element-type element-type
1201                                    :interactive nil
1202                                    :sharing sharing
1203                                    :basic t
1204                                    :encoding (external-format-character-encoding external-format)
1205                                    :line-termination (external-format-line-termination external-format)
1206                                    :auto-close t)
1207                    (cons read-pipe close-in-parent)
1208                    (cons write-pipe close-on-error)))
1209           (:output
1210            (values write-pipe
1211                    (make-fd-stream read-pipe
1212                                    :direction :input
1213                                    :element-type element-type
1214                                    :interactive t
1215                                    :basic t
1216                                    :sharing sharing
1217                                    :encoding (external-format-character-encoding external-format)
1218                                    :line-termination (external-format-line-termination external-format)
1219                                    :auto-close t)
1220                    (cons write-pipe close-in-parent)
1221                    (cons read-pipe close-on-error)))
1222           (t
1223            (fd-close read-pipe)
1224            (fd-close write-pipe)
1225            (report-bad-arg direction '(member :input :output))))))
1226      ((or pathname string)
1227       (with-open-stream (file (apply #'open object keys))
1228         (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)))))
1229           (values fd
1230                   nil
1231                   (cons fd close-in-parent)
1232                   (cons fd close-on-error)))))
1233      #||
1234      ;; What's an FD-STREAM ?
1235      (fd-stream
1236       (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
1237         (values fd
1238                 nil
1239                 (cons fd close-in-parent)
1240                 (cons fd close-on-error))))
1241      ||#
1242      (stream
1243       (ecase direction
1244         (:input
1245          (with-cstrs ((template #-android-target "/tmp/lisp-tempXXXXXX"
1246                                 #+android-target "/data/local/tmp/lisp-tempXXXXXX"))
1247            (let* ((fd (#_mkstemp template)))
1248              (if (< fd 0)
1249                (%errno-disp fd))
1250              (#_unlink template)
1251              (let* ((out (make-fd-stream (fd-dup fd)
1252                                          :direction :output
1253                                          :encoding (external-format-character-encoding external-format)
1254                                          :line-termination (external-format-line-termination external-format))))
1255                (loop
1256                  (multiple-value-bind (line no-newline)
1257                      (read-line object nil nil)
1258                    (unless line
1259                      (return))
1260                    (if no-newline
1261                      (write-string line out)
1262                      (write-line line out))))
1263                (close out))
1264              (fd-lseek fd 0 #$SEEK_SET)
1265              (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))))
1266         (:output
1267          (multiple-value-bind (read-pipe write-pipe) (pipe)
1268            (push read-pipe (external-process-watched-fds proc))
1269            (push object (external-process-watched-streams proc))
1270            (incf (car (external-process-token proc)))
1271            (values write-pipe
1272                    nil
1273                    (cons write-pipe close-in-parent)
1274                    (cons read-pipe close-on-error))))))))
1275
1276  (let* ((external-processes ())
1277         (external-processes-lock (make-lock)))
1278    (defun add-external-process (p)
1279      (with-lock-grabbed (external-processes-lock)
1280        (push p external-processes)))
1281    (defun remove-external-process (p)
1282      (with-lock-grabbed (external-processes-lock)
1283        (setq external-processes (delete p external-processes))))
1284    ;; Likewise
1285    (defun external-processes ()
1286      (with-lock-grabbed (external-processes-lock)
1287        (copy-list external-processes)))
1288    )
1289
1290
1291  (defmacro wtermsig (status)
1292    `(ldb (byte 7 0) ,status))
1293
1294  (defmacro wexitstatus (status)
1295    `(ldb (byte 8 8) (the fixnum ,status)))
1296
1297  (defmacro wstopsig (status)
1298    `(wexitstatus ,status))
1299
1300  (defmacro wifexited (status)
1301    `(eql (wtermsig ,status) 0))
1302
1303  (defmacro wifstopped (status)
1304    `(eql #x7f (ldb (byte 7 0) (the fixnum ,status))))
1305
1306  (defun monitor-external-process (p)
1307    (let* ((in-fds (external-process-watched-fds p))
1308           (out-streams (external-process-watched-streams p))
1309           (token (external-process-token p))
1310           (terminated)
1311           (changed)
1312           (maxfd 0)
1313           (external-format (external-process-external-format p))
1314           (encoding (external-format-character-encoding external-format))
1315           (line-termination (external-format-line-termination external-format))
1316           (pairs (pairlis
1317                   (mapcar (lambda (fd)
1318                             (cons fd
1319                                   (make-fd-stream fd
1320                                                   :direction :input
1321                                                   :sharing :private
1322                                                   :encoding encoding
1323                                                   :interactive t
1324                                                   :line-termination line-termination)))
1325                                     in-fds) out-streams)))
1326      (%stack-block ((in-fd-set *fd-set-size*))
1327        (rlet ((tv #>timeval))
1328          (loop
1329            (when changed
1330              (setq pairs (delete nil pairs :key #'car)
1331                    changed nil))
1332            (when (and terminated (null pairs))
1333              (signal-semaphore (external-process-completed p))
1334              (return))
1335            (when pairs
1336              (fd-zero in-fd-set)
1337              (setq maxfd 0)
1338              (dolist (p pairs)
1339                (let* ((fd (caar p)))
1340                  (when (> fd maxfd)
1341                    (setq maxfd fd))
1342                  (fd-set fd in-fd-set)))
1343              (setf (pref tv #>timeval.tv_sec) 1
1344                    (pref tv #>timeval.tv_usec) 0)
1345              (when (> (#_select (1+ maxfd) in-fd-set (%null-ptr) (%null-ptr) tv)
1346                       0)
1347                (dolist (p pairs)
1348                  (let* ((in-fd (caar p))
1349                         (in-stream (cdar p))
1350                         (out-stream (cdr p)))
1351                    (when (fd-is-set in-fd in-fd-set)
1352                      (let* ((buf (make-string 1024))
1353                             (n (ignore-errors (read-sequence buf in-stream))))
1354                        (declare (dynamic-extent buf))
1355                        (if (or (null n) (eql n 0))
1356                          (without-interrupts
1357                           (decf (car token))
1358                           (close in-stream)
1359                           (setf (car p) nil changed t))
1360                          (write-sequence buf out-stream :end n))))))))
1361            (let* ((statusflags (check-pid (external-process-pid p)
1362                                           (logior
1363                                            (if in-fds #$WNOHANG 0)
1364                                            #$WUNTRACED)))
1365                   (oldstatus (external-process-%status p)))
1366              (cond ((null statusflags)
1367                     (remove-external-process p)
1368                     (setq terminated t))
1369                    ((eq statusflags t)) ; Running.
1370                    (t
1371                     (multiple-value-bind (status code core)
1372                         (cond ((wifstopped statusflags)
1373                                (values :stopped (wstopsig statusflags)))
1374                               ((wifexited statusflags)
1375                                (values :exited (wexitstatus statusflags)))
1376                               (t
1377                                (let* ((signal (wtermsig statusflags)))
1378                                  (declare (fixnum signal))
1379                                  (values
1380                                   (if (or (= signal #$SIGSTOP)
1381                                           (= signal #$SIGTSTP)
1382                                           (= signal #$SIGTTIN)
1383                                           (= signal #$SIGTTOU))
1384                                     :stopped
1385                                     :signaled)
1386                                   signal
1387                                   (logtest #-(or solaris-target android-target)
1388                                            #$WCOREFLAG
1389                                            #+solaris-target #$WCOREFLG
1390                                            #+android-target #x80
1391                                            statusflags)))))
1392                       (setf (external-process-%status p) status
1393                             (external-process-%exit-code p) code
1394                             (external-process-core p) core)
1395                       (let* ((status-hook (external-process-status-hook p)))
1396                         (when (and status-hook (not (eq oldstatus status)))
1397                           (funcall status-hook p)))
1398                       (when (or (eq status :exited)
1399                                 (eq status :signaled))
1400                         (remove-external-process p)
1401                         (setq terminated t)))))))))))
1402     
1403  (defun run-external-process (proc in-fd out-fd error-fd argv &optional env)
1404    (let* ((signaled nil))
1405      (unwind-protect
1406           (let* ((child-pid (#-solaris-target #_fork #+solaris-target #_forkall)))
1407             (declare (fixnum child-pid))
1408             (cond ((zerop child-pid)
1409                    ;; Running in the child; do an exec
1410                    (setq signaled t)
1411                    (dolist (pair env)
1412                      (setenv (string (car pair)) (cdr pair)))
1413                    (without-interrupts
1414                     (exec-with-io-redirection
1415                      in-fd out-fd error-fd argv)))
1416                   ((> child-pid 0)
1417                    ;; Running in the parent: success
1418                    (setf (external-process-pid proc) child-pid)
1419                    (add-external-process proc)
1420                    (signal-semaphore (external-process-signal proc))
1421                    (setq signaled t)
1422                    (monitor-external-process proc))
1423                   (t
1424                    ;; Fork failed
1425                    (setf (external-process-%status proc) :error
1426                          (external-process-%exit-code proc) (%get-errno))
1427                    (signal-semaphore (external-process-signal proc))
1428                    (setq signaled t))))
1429        (unless signaled
1430          (setf (external-process-%status proc) :error
1431                (external-process-%exit-code proc) -1)
1432          (signal-semaphore (external-process-signal proc))))))
1433
1434  (defparameter *silently-ignore-catastrophic-failure-in-run-program* nil
1435    "If NIL, signal an error if run-program is unable to start the program.
1436If non-NIL, treat failure to start the same as failure from the program
1437itself, by setting the status and exit-code fields.")
1438
1439  (defun run-program (program args &key
1440                              (wait t) pty
1441                              input if-input-does-not-exist
1442                              output (if-output-exists :error)
1443                              (error :output) (if-error-exists :error)
1444                              status-hook (element-type 'character)
1445                              env
1446                              (sharing :private)
1447                              (external-format `(:character-encoding ,*terminal-character-encoding-name*))
1448                              (silently-ignore-catastrophic-failures
1449                               *silently-ignore-catastrophic-failure-in-run-program*))
1450    "Invoke an external program as an OS subprocess of lisp."
1451    (declare (ignore pty))
1452    (unless (every #'(lambda (a) (typep a 'simple-string)) args)
1453      (error "Program args must all be simple strings : ~s" args))
1454    (dolist (pair env)
1455      (destructuring-bind (var . val) pair
1456        (check-type var (or string symbol character))
1457        (check-type val string)))
1458    (push (native-untranslated-namestring program) args)
1459    (let* ((token (list 0))
1460           (in-fd nil)
1461           (in-stream nil)
1462           (out-fd nil)
1463           (out-stream nil)
1464           (error-fd nil)
1465           (error-stream nil)
1466           (close-in-parent nil)
1467           (close-on-error nil)
1468           (proc
1469            (make-external-process
1470             :pid nil
1471             :args args
1472             :%status :running
1473             :input nil
1474             :output nil
1475             :error nil
1476             :token token
1477             :status-hook status-hook
1478             :external-format (setq external-format (normalize-external-format t external-format)))))
1479      (unwind-protect
1480           (progn
1481             (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
1482               (get-descriptor-for input proc  nil nil :direction :input
1483                                   :if-does-not-exist if-input-does-not-exist
1484                                   :element-type element-type
1485                                   :sharing sharing
1486                                   :external-format external-format))
1487             (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
1488               (get-descriptor-for output proc close-in-parent close-on-error
1489                                   :direction :output
1490                                   :if-exists if-output-exists
1491                                   :element-type element-type
1492                                   :sharing sharing
1493                                   :external-format external-format))
1494             (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
1495               (if (eq error :output)
1496                 (values out-fd out-stream close-in-parent close-on-error)
1497                 (get-descriptor-for error proc close-in-parent close-on-error
1498                                     :direction :output
1499                                     :if-exists if-error-exists
1500                                     :sharing sharing
1501                                     :element-type element-type
1502                                     :external-format external-format)))
1503             (setf (external-process-input proc) in-stream
1504                   (external-process-output proc) out-stream
1505                   (external-process-error proc) error-stream)
1506             (call-with-string-vector
1507              #'(lambda (argv)
1508                  (process-run-function
1509                   (list :name
1510                         (format nil "Monitor thread for external process ~a" args)
1511                         :stack-size (ash 128 10)
1512                         :vstack-size (ash 128 10)
1513                         :tstack-size (ash 128 10))
1514                   #'run-external-process proc in-fd out-fd error-fd argv env)
1515                  (wait-on-semaphore (external-process-signal proc)))
1516              args))
1517        (dolist (fd close-in-parent) (fd-close fd))
1518        (unless (external-process-pid proc)
1519          (dolist (fd close-on-error) (fd-close fd)))
1520        (when (and wait (external-process-pid proc))
1521          (with-interrupts-enabled
1522              (wait-on-semaphore (external-process-completed proc)))))
1523      (unless (external-process-pid proc)
1524        ;; something is wrong
1525        (if (eq (external-process-%status proc) :error)
1526          ;; Fork failed
1527          (unless silently-ignore-catastrophic-failures
1528            (cerror "Pretend the program ran and failed" 'external-process-creation-failure :proc proc))
1529          ;; Currently can't happen.
1530          (error "Bug: fork failed but status field not set?")))
1531      proc))
1532
1533
1534
1535  (defmacro wifsignaled (status)
1536    (let* ((statname (gensym)))
1537      `(let* ((,statname ,status))
1538        (and (not (wifstopped ,statname)) (not (wifexited ,statname))))))
1539
1540
1541  (defun check-pid (pid &optional (flags (logior  #$WNOHANG #$WUNTRACED)))
1542    (declare (fixnum pid))
1543    (rlet ((status :signed))
1544      (let* ((retval (ff-call-ignoring-eintr (#_waitpid pid status flags))))
1545        (declare (fixnum retval))
1546        (if (= retval pid)
1547          (pref status :signed)
1548          (zerop retval)))))
1549
1550
1551
1552
1553
1554  (defun external-process-wait (proc &optional check-stopped)
1555    (process-wait "external-process-wait"
1556                  #'(lambda ()
1557                      (case (external-process-%status proc)
1558                        (:running)
1559                        (:stopped
1560                         (when check-stopped
1561                           t))
1562                        (t
1563                         (when (zerop (car (external-process-token proc)))
1564                           t))))))
1565 
1566  (defun signal-external-process (proc signal &key (error-if-exited t))
1567    "Send the specified signal to the specified external process.  (Typically,
1568it would only be useful to call this function if the EXTERNAL-PROCESS was
1569created with :WAIT NIL.) Return T if successful; NIL if the process wasn't
1570created successfully, and signal an error otherwise."
1571    (require-type proc 'external-process)
1572    (let* ((pid (external-process-pid proc)))
1573      (when pid
1574        (let ((error (int-errno-call (#_kill pid signal))))
1575          (or (eql error 0)
1576              (unless (and (eql error (- #$ESRCH))
1577                           (not error-if-exited))
1578                (%errno-disp error)))))))
1579
1580  )                                     ; #-windows-target (progn
1581
1582#+windows-target
1583(progn
1584  (defun temp-file-name (prefix)
1585    "Returns a unique name for a temporary file, residing in system temp
1586space, and prefixed with PREFIX."
1587    (rlet ((buffer (:array :wchar_t #.#$MAX_PATH)))
1588      (#_GetTempPathW #$MAX_PATH buffer)
1589      (with-filename-cstrs ((c-prefix prefix)) 
1590        (#_GetTempFileNameW buffer c-prefix 0 buffer)
1591        (%get-native-utf-16-cstring buffer))))
1592 
1593  (defun get-descriptor-for (object proc close-in-parent close-on-error
1594                                    &rest keys
1595                                    &key
1596                                    direction (element-type 'character)
1597                                    (sharing :private)
1598                                    external-format
1599                                    &allow-other-keys)
1600    (etypecase object
1601      ((eql t)
1602       (values nil nil close-in-parent close-on-error))
1603      (null
1604       (let* ((null-device "nul")
1605              (fd (fd-open null-device (case direction
1606                                         (:input #$O_RDONLY)
1607                                         (:output #$O_WRONLY)
1608                                         (t #$O_RDWR)))))
1609         (if (< fd 0)
1610           (signal-file-error fd null-device))
1611         (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
1612      ((eql :stream)
1613       (multiple-value-bind (read-pipe write-pipe) (pipe)
1614         (case direction
1615           (:input
1616            (values read-pipe
1617                    (make-fd-stream (fd-uninheritable write-pipe :direction :output)
1618                                    :direction :output
1619                                    :element-type element-type
1620                                    :interactive nil
1621                                    :basic t
1622                                    :sharing sharing
1623                                    :encoding (external-format-character-encoding external-format)
1624                                    :line-termination (external-format-line-termination external-format)
1625                                    :auto-close t)
1626                    (cons read-pipe close-in-parent)
1627                    (cons write-pipe close-on-error)))
1628           (:output
1629            (values write-pipe
1630                    (make-fd-stream (fd-uninheritable read-pipe :direction :input)
1631                                    :direction :input
1632                                    :element-type element-type
1633                                    :interactive t
1634                                    :basic t
1635                                    :sharing sharing
1636                                    :encoding (external-format-character-encoding external-format)
1637                                    :line-termination (external-format-line-termination external-format)
1638                                    :auto-close t)
1639                    (cons write-pipe close-in-parent)
1640                    (cons read-pipe close-on-error)))
1641           (t
1642            (fd-close read-pipe)
1643            (fd-close write-pipe)
1644            (report-bad-arg direction '(member :input :output))))))
1645      ((or pathname string)
1646       (with-open-stream (file (apply #'open object keys))
1647         (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)) :direction direction :inheritable t)))
1648           (values fd
1649                   nil
1650                   (cons fd close-in-parent)
1651                   (cons fd close-on-error)))))
1652      (stream
1653       (ecase direction
1654         (:input
1655          (let* ((tempname (temp-file-name "lisp-temp"))
1656                 (fd (fd-open tempname #$O_RDWR)))
1657            (if (< fd 0)
1658              (%errno-disp fd))
1659            (let* ((out (make-fd-stream (fd-dup fd)
1660                                        :direction :output
1661                                        :encoding (external-format-character-encoding external-format)
1662                                        :line-termination (external-format-line-termination external-format))))           
1663              (loop
1664                (multiple-value-bind (line no-newline)
1665                    (read-line object nil nil)
1666                  (unless line
1667                    (return))
1668                  (if no-newline
1669                    (write-string line out)
1670                    (write-line line out))
1671                  ))
1672              (close out))
1673            (fd-lseek fd 0 #$SEEK_SET)
1674            (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
1675         (:output
1676          (multiple-value-bind (read-pipe write-pipe) (pipe)
1677            (push read-pipe (external-process-watched-fds proc))
1678            (push object (external-process-watched-streams proc))
1679            (incf (car (external-process-token proc)))
1680            (values write-pipe
1681                    nil
1682                    (cons write-pipe close-in-parent)
1683                    (cons read-pipe close-on-error))))))))
1684
1685  (defstruct external-process
1686    pid
1687    %status
1688    %exit-code
1689    pty
1690    input
1691    output
1692    error
1693    status-hook
1694    plist
1695    token
1696    core
1697    args
1698    (signal (make-semaphore))
1699    (completed (make-semaphore))
1700    watched-fds
1701    watched-streams
1702    external-format
1703    )
1704
1705
1706
1707  (defmethod print-object ((p external-process) stream)
1708    (print-unreadable-object (p stream :type t :identity t)
1709      (let* ((status (external-process-%status p)))
1710        (let* ((*print-length* 3))
1711          (format stream "~a" (external-process-args p)))
1712        (format stream "[~d] (~a" (external-process-pid p) status)
1713        (unless (eq status :running)
1714          (format stream " : ~d" (external-process-%exit-code p)))
1715        (format stream ")"))))
1716
1717  (defun run-program (program args &key
1718                              (wait t) pty
1719                              input if-input-does-not-exist
1720                              output (if-output-exists :error)
1721                              (error :output) (if-error-exists :error)
1722                              status-hook (element-type 'character)
1723                              (sharing :private)
1724                              (external-format `(:character-encoding ,*terminal-character-encoding-name* :line-termination :crlf))
1725                              env)
1726    "Invoke an external program as an OS subprocess of lisp."
1727    (declare (ignore pty))
1728    (push program args)
1729    (unless (do* ((args args (cdr args)))
1730                 ((atom args)
1731                  (or (typep args 'simple-string)
1732                      (null args)))
1733              (unless (typep (car args) 'simple-string)
1734                (return)))
1735      (error "Program args must all be simple strings : ~s" args))
1736    (let* ((token (list 0))
1737           (in-fd nil)
1738           (in-stream nil)
1739           (out-fd nil)
1740           (out-stream nil)
1741           (error-fd nil)
1742           (error-stream nil)
1743           (close-in-parent nil)
1744           (close-on-error nil)
1745           (proc
1746            (make-external-process
1747             :pid nil
1748             :args args
1749             :%status :running
1750             :input nil
1751             :output nil
1752             :error nil
1753             :token token
1754             :external-format (setq external-format (normalize-external-format t external-format))
1755             :status-hook status-hook)))
1756      (unwind-protect
1757           (progn
1758             (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
1759               (get-descriptor-for input proc  nil nil :direction :input
1760                                   :if-does-not-exist if-input-does-not-exist
1761                                   :sharing sharing
1762                                   :element-type element-type
1763                                   :external-format external-format))
1764             (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
1765               (get-descriptor-for output proc close-in-parent close-on-error
1766                                   :direction :output
1767                                   :if-exists if-output-exists
1768                                   :sharing sharing
1769                                   :element-type element-type
1770                                   :external-format external-format))
1771             (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
1772               (if (eq error :output)
1773                 (values out-fd out-stream close-in-parent close-on-error)
1774                 (get-descriptor-for error proc close-in-parent close-on-error
1775                                     :direction :output
1776                                     :if-exists if-error-exists
1777                                     :sharing sharing
1778                                     :element-type element-type
1779                                     :external-format external-format)))
1780             (setf (external-process-input proc) in-stream
1781                   (external-process-output proc) out-stream
1782                   (external-process-error proc) error-stream)
1783             (process-run-function
1784              (format nil "Monitor thread for external process ~a" args)
1785                   
1786              #'run-external-process proc in-fd out-fd error-fd env)
1787             (wait-on-semaphore (external-process-signal proc))
1788             )
1789        (dolist (fd close-in-parent) (fd-close fd))
1790        (if (external-process-pid proc)
1791          (when (and wait (external-process-pid proc))
1792            (with-interrupts-enabled
1793                (wait-on-semaphore (external-process-completed proc))))
1794          (progn
1795            (dolist (fd close-on-error) (fd-close fd)))))
1796      proc))
1797
1798  (let* ((external-processes ())
1799         (external-processes-lock (make-lock)))
1800    (defun add-external-process (p)
1801      (with-lock-grabbed (external-processes-lock)
1802        (push p external-processes)))
1803    (defun remove-external-process (p)
1804      (with-lock-grabbed (external-processes-lock)
1805        (setq external-processes (delete p external-processes))))
1806    ;; Likewise
1807    (defun external-processes ()
1808      (with-lock-grabbed (external-processes-lock)
1809        (copy-list external-processes)))
1810    )
1811
1812
1813
1814
1815  (defun run-external-process (proc in-fd out-fd error-fd &optional env)
1816    (let* ((args (external-process-args proc))
1817           (child-pid (exec-with-io-redirection in-fd out-fd error-fd args proc env)))
1818      (when child-pid
1819        (setf (external-process-pid proc) child-pid)
1820        (add-external-process proc)
1821        (signal-semaphore (external-process-signal proc))
1822        (monitor-external-process proc))))
1823
1824  (defun make-windows-command-line (strings)
1825    (with-output-to-string (out)
1826      (do* ((strings strings (cdr strings)))
1827           ((atom strings)     
1828            (if strings (write-string strings out)))
1829        (let* ((string (car strings))
1830               (n (length string))
1831               (quote-backslash 0)
1832               (literal-backslash 0))
1833          (declare (fixnum n quote-backslash literal-backslash))
1834          (dotimes (i n)
1835            (let* ((c (schar string i)))
1836              (case c
1837                (#\\
1838                 (unless (or (> quote-backslash 0)
1839                             (> literal-backslash 0))
1840                   (do* ((j i (1+ j))
1841                         (k 0))
1842                        ((= j n) (setq literal-backslash k))
1843                     (case (schar string j)
1844                       (#\\ (incf k))
1845                       ((#\space #\tab #\")
1846                        (setq quote-backslash k)
1847                        (return))
1848                       (t (setq literal-backslash k)
1849                          (return)))))
1850                 (if (> quote-backslash 0)
1851                   (progn
1852                     (write-char #\\ out)
1853                     (write-char #\\ out)
1854                     (decf quote-backslash))
1855                   (progn
1856                     (write-char #\\ out)
1857                     (decf literal-backslash))))
1858                ((#\space #\tab)
1859                 (write-char #\" out)
1860                 (write-char c out)
1861                 (write-char #\" out))
1862                (#\"
1863                 (write-char #\\ out)
1864                 (write-char #\" out))
1865                (t (write-char c out)))))
1866          (when strings (write-char #\space out))))))
1867
1868  (defun create-windows-process (new-in new-out new-err cmdstring env)
1869    (declare (ignore env))              ; until we can do better.
1870    (with-filename-cstrs ((command cmdstring))
1871      (rletz ((proc-info #>PROCESS_INFORMATION)
1872              (si #>STARTUPINFO))
1873        (setf (pref si #>STARTUPINFO.cb) (record-length #>STARTUPINFO))
1874        (setf (pref si #>STARTUPINFO.dwFlags)
1875              (logior #$STARTF_USESTDHANDLES #$STARTF_USESHOWWINDOW))
1876        (setf (pref si #>STARTUPINFO.wShowWindow) #$SW_HIDE)
1877        (setf (pref si #>STARTUPINFO.hStdInput)
1878              (if new-in
1879                (%int-to-ptr new-in)
1880                (#_GetStdHandle #$STD_INPUT_HANDLE)))
1881        (setf (pref si #>STARTUPINFO.hStdOutput)
1882              (if new-out
1883                (%int-to-ptr new-out)
1884                (#_GetStdHandle #$STD_OUTPUT_HANDLE)))
1885        (setf (pref si #>STARTUPINFO.hStdError)
1886              (if new-err
1887                (%int-to-ptr new-err)
1888                (#_GetStdHandle #$STD_ERROR_HANDLE)))
1889        (if (zerop (#_CreateProcessW (%null-ptr)
1890                                     command
1891                                     (%null-ptr)
1892                                     (%null-ptr)
1893                                     1
1894                                     #$CREATE_NEW_CONSOLE
1895                                     (%null-ptr)
1896                                     (%null-ptr)
1897                                     si
1898                                     proc-info))
1899          (values nil (#_GetLastError))
1900          (progn
1901            (#_CloseHandle (pref proc-info #>PROCESS_INFORMATION.hThread))
1902            (values t (pref proc-info #>PROCESS_INFORMATION.hProcess)))))))
1903
1904  (defun exec-with-io-redirection (new-in new-out new-err args proc &optional env)
1905    (multiple-value-bind (win handle-to-process-or-error)
1906        (create-windows-process new-in new-out new-err (make-windows-command-line args) env)
1907      (if win
1908        handle-to-process-or-error
1909        (progn
1910          (setf (external-process-%status proc) :error
1911                (external-process-%exit-code proc) handle-to-process-or-error)
1912          (signal-semaphore (external-process-signal proc))
1913          (signal-semaphore (external-process-completed proc))
1914          nil))))
1915
1916  (defun fd-uninheritable (fd &key direction)
1917    (let ((new-fd (fd-dup fd :direction direction)))
1918      (fd-close fd)
1919      new-fd))
1920
1921 
1922  (defun data-available-on-pipe-p (hpipe)
1923    (rlet ((navail #>DWORD 0))
1924      (unless (eql 0 (#_PeekNamedPipe (if (typep hpipe 'macptr)
1925                                        hpipe
1926                                        (%int-to-ptr hpipe))
1927                                      (%null-ptr)
1928                                      0
1929                                      (%null-ptr)
1930                                      navail
1931                                      (%null-ptr)))
1932        (not (eql 0 (pref navail #>DWORD))))))
1933   
1934
1935  ;;; There doesn't seem to be any way to wait on input from an
1936  ;;; anonymous pipe in Windows (that would, after all, make too
1937  ;;; much sense.)  We -can- check for pending unread data on
1938  ;;; pipes, and can expect to eventually get EOF on a pipe.
1939  ;;; So, this tries to loop until the process handle is signaled and
1940  ;;; all data has been read.
1941  (defun monitor-external-process (p)
1942    (let* ((in-fds (external-process-watched-fds p))
1943           (out-streams (external-process-watched-streams p))
1944           (token (external-process-token p))
1945           (terminated)
1946           (changed)
1947           (external-format (external-process-external-format p))
1948           (encoding (external-format-character-encoding external-format))
1949           (line-termination (external-format-line-termination external-format))
1950           (pairs (pairlis (mapcar (lambda (fd)
1951                                     (cons fd
1952                                           (make-fd-stream fd
1953                                                           :direction :input
1954                                                           :sharing :private
1955                                                           :encoding encoding
1956                                                           :interactive t
1957                                                           :line-termination line-termination)))
1958                                   in-fds)
1959                           out-streams))
1960           )
1961      (loop
1962        (when changed
1963          (setq pairs (delete nil pairs :key #'car)
1964                changed nil))
1965        (when (and terminated (null pairs))
1966          (without-interrupts
1967           (rlet ((code #>DWORD))
1968             (loop
1969               (#_GetExitCodeProcess (external-process-pid p) code)
1970               (unless (eql (pref code #>DWORD) #$STILL_ACTIVE)
1971                 (return))
1972               (#_SleepEx 10 #$TRUE))
1973             (setf (external-process-%exit-code p) (pref code #>DWORD)))
1974           (#_CloseHandle (external-process-pid p))
1975           (setf (external-process-pid p) nil)
1976           (setf (external-process-%status p) :exited)
1977           (let ((status-hook (external-process-status-hook p)))
1978             (when status-hook
1979               (funcall status-hook p)))
1980           (remove-external-process p)
1981           (signal-semaphore (external-process-completed p))
1982           (return)))
1983        (dolist (p pairs)
1984          (let* ((in-fd (caar p))
1985                 (in-stream (cdar p))
1986                 (out-stream (cdr p)))
1987            (when (or terminated (data-available-on-pipe-p in-fd))
1988              (let* ((buf (make-string 1024)))
1989                (declare (dynamic-extent buf))
1990                (let* ((n (ignore-errors (read-sequence buf in-stream))))
1991                  (if (or (null n) (eql n 0))
1992                    (progn
1993                      (without-interrupts
1994                       (decf (car token))
1995                       (fd-close in-fd)
1996                       (setf (car p) nil changed t)))
1997                    (progn
1998                      (write-sequence buf out-stream :end n)
1999                      (force-output out-stream))))))))
2000        (unless terminated
2001          (setq terminated (eql (#_WaitForSingleObjectEx
2002                                 (external-process-pid p)
2003                                 1000
2004                                 #$true)
2005                                #$WAIT_OBJECT_0))))))
2006 
2007
2008  (defun signal-external-process (proc signal)
2009    "Does nothing on Windows"
2010    (declare (ignore signal))
2011    (require-type proc 'external-process)
2012    nil) 
2013
2014
2015  )
2016                                        ;#+windows-target (progn
2017
2018
2019(defun external-process-input-stream (proc)
2020  "Return the lisp stream which is used to write input to a given OS
2021subprocess, if it has one."
2022  (require-type proc 'external-process)
2023  (external-process-input proc))
2024
2025(defun external-process-output-stream (proc)
2026  "Return the lisp stream which is used to read output from a given OS
2027subprocess, if there is one."
2028  (require-type proc 'external-process)
2029  (external-process-output proc))
2030
2031(defun external-process-error-stream (proc)
2032  "Return the stream which is used to read error output from a given OS
2033subprocess, if it has one."
2034  (require-type proc 'external-process)
2035  (external-process-error proc))
2036
2037(defun external-process-id (proc)
2038  "Return the process id of an OS subprocess, a positive integer which
2039identifies it."
2040  (require-type proc 'external-process)
2041  (external-process-pid proc))
2042
2043(defun external-process-status (proc)
2044  "Return information about whether an OS subprocess is running; or, if
2045not, why not; and what its result code was if it completed."
2046  (require-type proc 'external-process)
2047  (values (external-process-%status proc)
2048          (external-process-%exit-code proc)))
2049
2050;;; EOF on a TTY is transient, but I'm less sure of other cases.
2051(defun eof-transient-p (fd)
2052  (case (%unix-fd-kind fd)
2053    (:tty t)
2054    #+windows-target (:character-special t)
2055    (t nil)))
2056
2057
2058(defstruct (shared-resource (:constructor make-shared-resource (name)))
2059  (name)
2060  (lock (make-lock))
2061  (primary-owner *current-process*)
2062  (primary-owner-notify (make-semaphore))
2063  (current-owner nil)
2064  (requestors (make-dll-header)))
2065
2066(defstruct (shared-resource-request
2067             (:constructor make-shared-resource-request (process))
2068             (:include dll-node))
2069  process
2070  (signal (make-semaphore)))
2071             
2072
2073;; Returns NIL if already owned by calling thread, T otherwise
2074(defun %acquire-shared-resource (resource  &optional verbose)
2075  (let* ((current *current-process*))
2076    (with-lock-grabbed ((shared-resource-lock resource))
2077      (let* ((secondary (shared-resource-current-owner resource)))
2078        (if (or (eq current secondary)
2079                (and (null secondary)
2080                     (eq current (shared-resource-primary-owner resource))))
2081          (return-from %acquire-shared-resource nil))))
2082    (let* ((request (make-shared-resource-request *current-process*)))
2083      (when verbose
2084        (format t "~%~%;;;~%;;; ~a requires access to ~a~%;;; Type (:y ~D) to yield control to this thread.~%;;;~%"
2085                *current-process* (shared-resource-name resource)
2086                (process-serial-number *current-process*))
2087        (force-output t))
2088      (with-lock-grabbed ((shared-resource-lock resource))
2089        (append-dll-node request (shared-resource-requestors resource)))
2090      (wait-on-semaphore (shared-resource-request-signal request))
2091      (assert (eq current (shared-resource-current-owner resource)))
2092      (when verbose
2093        (format t "~%~%;;;~%;;; ~a is now owned by ~a~%;;;~%~%"
2094                (shared-resource-name resource) current))
2095      t)))
2096
2097;;; If we're the primary owner and there is no secondary owner, do nothing.
2098;;; If we're the secondary owner, cease being the secondary owner.
2099(defun %release-shared-resource (r)
2100  (let* ((not-any-owner ()))
2101    (with-lock-grabbed ((shared-resource-lock r))
2102      (let* ((current *current-process*)
2103             (primary (shared-resource-primary-owner r))
2104             (secondary (shared-resource-current-owner r)))
2105        (unless (setq not-any-owner
2106                      (not (or (eq current secondary)
2107                               (and (null secondary)
2108                                    (eq current primary)))))
2109          (when (eq current secondary)
2110            (setf (shared-resource-current-owner r) nil)
2111            (signal-semaphore (shared-resource-primary-owner-notify r))))))
2112    (when not-any-owner
2113      (signal-program-error "Process ~a does not own ~a" *current-process*
2114                            (shared-resource-name r)))))
2115
2116;;; The current thread should be the primary owner; there should be
2117;;; no secondary owner.  Wakeup the specified (or first) requesting
2118;;; process, then block on our semaphore
2119(defun %yield-shared-resource (r &optional to)
2120  (let* ((request nil))
2121    (with-lock-grabbed ((shared-resource-lock r))
2122      (let* ((current *current-process*)
2123             (primary (shared-resource-primary-owner r)))
2124        (when (and (eq current primary)
2125                   (null (shared-resource-current-owner r)))
2126          (setq request
2127                (let* ((header (shared-resource-requestors r)))
2128                  (if to 
2129                    (do-dll-nodes (node header)
2130                      (when (eq to (shared-resource-request-process node))
2131                        (return node)))
2132                    (let* ((first (dll-header-first header)))
2133                      (unless (eq first header)
2134                        first)))))
2135          (when request
2136            (remove-dll-node request)
2137            (setf (shared-resource-current-owner r)
2138                  (shared-resource-request-process request))
2139            (signal-semaphore (shared-resource-request-signal request))))))
2140    (when request
2141      (wait-on-semaphore (shared-resource-primary-owner-notify r))
2142      (format t "~%;;;~%;;;control of ~a restored to ~a~%;;;~&"
2143              (shared-resource-name r)
2144              *current-process*))))
2145
2146
2147     
2148
2149(defun %shared-resource-requestor-p (r proc)
2150  (with-lock-grabbed ((shared-resource-lock r))
2151    (do-dll-nodes (node (shared-resource-requestors r))
2152      (when (eq proc (shared-resource-request-process node))
2153        (return t)))))
2154
2155(defparameter *resident-editor-hook* nil
2156  "If non-NIL, should be a function that takes an optional argument
2157   (like ED) and invokes a \"resident\" editor.")
2158
2159(defun ed (&optional arg)
2160  (if *resident-editor-hook*
2161    (funcall *resident-editor-hook* arg)
2162    (error "This implementation doesn't provide a resident editor.")))
2163
2164(defun running-under-emacs-p ()
2165  (not (null (getenv "EMACS"))))
2166
2167(defloadvar *cpu-count* nil)
2168
2169(defun cpu-count ()
2170  (or *cpu-count*
2171      (setq *cpu-count*
2172            #+darwin-target
2173            (rlet ((info :host_basic_info)
2174                   (count :mach_msg_type_number_t #$HOST_BASIC_INFO_COUNT))
2175              (if (eql #$KERN_SUCCESS (#_host_info (#_mach_host_self)
2176                                                   #$HOST_BASIC_INFO
2177                                                   info
2178                                                   count))
2179                (pref info :host_basic_info.max_cpus)
2180                1))
2181            #+(or linux-target solaris-target)
2182            (or
2183             (let* ((n (#_sysconf #$_SC_NPROCESSORS_CONF)))
2184               (declare (fixnum n))
2185               (if (> n 0) n))
2186             #+linux-target
2187             (ignore-errors
2188               (with-open-file (p "/proc/cpuinfo")
2189                 (let* ((ncpu 0)
2190                        (match "processor")
2191                        (matchlen (length match)))
2192                   (do* ((line (read-line p nil nil) (read-line p nil nil)))
2193                        ((null line) ncpu)
2194                     (let* ((line-length (length line)))
2195                       (when (and
2196                              (> line-length matchlen)
2197                              (string= match line
2198                                       :end2 matchlen)
2199                              (whitespacep (schar line matchlen)))
2200                         (incf ncpu)))))))
2201             1)
2202            #+freebsd-target
2203            (rlet ((ret :uint))
2204              (%stack-block ((mib (* (record-length :uint) 2)))
2205              (setf (paref mib (:array :uint) 0)
2206                    #$CTL_HW
2207                    (paref mib (:array :uint) 1)
2208                    #$HW_NCPU)
2209              (rlet ((oldsize :uint (record-length :uint)))
2210                (if (eql 0 (#_sysctl mib 2 ret oldsize (%null-ptr) 0))
2211                  (pref ret :uint)
2212                  1))))
2213            #+windows-target
2214            (rlet ((procmask #>DWORD_PTR)
2215                   (sysmask #>DWORD_PTR))
2216              (if (eql 0 (#_GetProcessAffinityMask (#_GetCurrentProcess) procmask sysmask))
2217                1
2218                (logcount (pref sysmask #>DWORD_PTR)))))))
2219
2220(def-load-pointers spin-count ()
2221  (if (eql 1 (cpu-count))
2222    (%defglobal '*spin-lock-tries* 1)
2223    (%defglobal '*spin-lock-tries* 1024))
2224  (%defglobal '*spin-lock-timeouts* 0))
2225
2226(defun yield ()
2227  (process-allow-schedule))
2228
2229(defloadvar *host-page-size*
2230    #-(or windows-target android-target)
2231    (#_getpagesize)
2232    #+windows-target
2233    (rlet ((info #>SYSTEM_INFO))
2234      (#_GetSystemInfo info)
2235      (pref info #>SYSTEM_INFO.dwPageSize))
2236    #+android-target
2237    (#_sysconf #$_SC_PAGE_SIZE)
2238    )
2239
2240;;(assert (= (logcount *host-page-size*) 1))
2241
2242
2243(defun same-fd-p (a b)
2244  (or (eql a b)
2245      #-windows-target
2246      (let* ((a-stat (multiple-value-list (%fstat a)))
2247             (b-stat (multiple-value-list (%fstat b))))
2248        (declare (dynamic-extent a-stat b-stat))
2249        (and (car a-stat) (car b-stat)
2250             (eql (nth 9 a-stat)
2251                  (nth 9 b-stat))
2252             (eql (nth 4 a-stat)
2253                  (nth 4 b-stat))))
2254      #+windows-target
2255      (%stack-block ((a-info (record-length #>BY_HANDLE_FILE_INFORMATION))
2256                     (b-info (record-length #>BY_HANDLE_FILE_INFORMATION)))
2257        (unless (or (eql 0 (#_GetFileInformationByHandle (%int-to-ptr a) a-info))
2258                    (eql 0 (#_GetFileInformationByHandle (%int-to-ptr b) b-info)))
2259          (and (eql (pref a-info #>BY_HANDLE_FILE_INFORMATION.dwVolumeSerialNumber)
2260                    (pref b-info #>BY_HANDLE_FILE_INFORMATION.dwVolumeSerialNumber))
2261               (eql (pref a-info #>BY_HANDLE_FILE_INFORMATION.nFileIndexHigh)
2262                    (pref b-info #>BY_HANDLE_FILE_INFORMATION.nFileIndexHigh))
2263               (eql (pref a-info #>BY_HANDLE_FILE_INFORMATION.nFileIndexLow)
2264                    (pref b-info #>BY_HANDLE_FILE_INFORMATION.nFileIndexLow)))))))
2265
2266 
2267(defun get-universal-time ()
2268  "Return a single integer for the current time of
2269   day in universal time format."
2270  (rlet ((tv :timeval))
2271    (gettimeofday tv)
2272    (+ (pref tv :timeval.tv_sec) unix-to-universal-time)))
2273
2274#+windows-target
2275(defloadvar *windows-allocation-granularity*
2276    (rlet ((info #>SYSTEM_INFO))
2277      (#_GetSystemInfo info)
2278      (pref info #>SYSTEM_INFO.dwAllocationGranularity)))
2279
2280#-windows-target
2281(defun %memory-map-fd (fd len bits-per-element)
2282  (let* ((nbytes (+ *host-page-size*
2283                    (logandc2 (+ len
2284                                 (1- *host-page-size*))
2285                              (1- *host-page-size*))))         
2286         (ndata-elements
2287          (ash len
2288               (ecase bits-per-element
2289                 (1 3)
2290                 (8 0)
2291                 (16 -1)
2292                 (32 -2)
2293                 (64 -3))))
2294         (nalignment-elements
2295          (ash target::nbits-in-word
2296               (ecase bits-per-element
2297                 (1 0)
2298                 (8 -3)
2299                 (16 -4)
2300                 (32 -5)
2301                 (64 -6)))))
2302    (if (>= (+ ndata-elements nalignment-elements)
2303            array-total-size-limit)
2304      (progn
2305        (fd-close fd)
2306        (error "Can't make a vector with ~s elements in this implementation." (+ ndata-elements nalignment-elements)))
2307      (let* ((addr (#_mmap (%null-ptr)
2308                           nbytes
2309                           #$PROT_NONE
2310                           (logior #$MAP_ANON #$MAP_PRIVATE)
2311                           -1
2312                           0)))             
2313        (if (eql addr (%int-to-ptr (1- (ash 1 target::nbits-in-word)))) ; #$MAP_FAILED
2314          (let* ((errno (%get-errno)))
2315            (fd-close fd)
2316            (error "Can't map ~d bytes: ~a" nbytes (%strerror errno)))
2317              ;;; Remap the first page so that we can put a vector header
2318              ;;; there; use the first word on the first page to remember
2319              ;;; the file descriptor.
2320          (progn
2321            (#_mmap addr
2322                    *host-page-size*
2323                    (logior #$PROT_READ #$PROT_WRITE)
2324                    (logior #$MAP_ANON #$MAP_PRIVATE #$MAP_FIXED)
2325                    -1
2326                    0)
2327            (setf (pref addr :int) fd)
2328            (let* ((header-addr (%inc-ptr addr (- *host-page-size*
2329                                                            (* 2 target::node-size)))))
2330             
2331              (when (> len 0)
2332                (let* ((target-addr (%inc-ptr header-addr (* 2 target::node-size))))
2333                  (unless (eql target-addr
2334                               (#_mmap target-addr
2335                                       len
2336                                       #$PROT_READ
2337                                       (logior #$MAP_PRIVATE #$MAP_FIXED)
2338                                       fd
2339                                       0))
2340                    (let* ((errno (%get-errno)))
2341                      (fd-close fd)
2342                      (#_munmap addr nbytes)
2343                      (error "Mapping failed: ~a" (%strerror errno))))))
2344              (values header-addr ndata-elements nalignment-elements))))))))
2345
2346#+windows-target
2347(defun %memory-map-fd (fd len bits-per-element)
2348  (let* ((nbytes (+ *windows-allocation-granularity*
2349                    (logandc2 (+ len
2350                                 (1- *windows-allocation-granularity*))
2351                              (1- *windows-allocation-granularity*))))         
2352         (ndata-elements
2353          (ash len
2354               (ecase bits-per-element
2355                 (1 3)
2356                 (8 0)
2357                 (16 -1)
2358                 (32 -2)
2359                 (64 -3))))
2360         (nalignment-elements
2361          (ash target::nbits-in-word
2362               (ecase bits-per-element
2363                 (1 0)
2364                 (8 -3)
2365                 (16 -4)
2366                 (32 -5)
2367                 (64 -6)))))
2368    (if (>= (+ ndata-elements nalignment-elements)
2369            array-total-size-limit)
2370      (progn
2371        (fd-close fd)
2372        (error "Can't make a vector with ~s elements in this implementation." (+ ndata-elements nalignment-elements)))
2373      (let* ((mapping (#_CreateFileMappingA (%int-to-ptr fd) (%null-ptr) #$PAGE_READONLY 0 0 (%null-ptr))))
2374        (if (%null-ptr-p mapping)
2375          (let* ((err (#_GetLastError)))
2376            (fd-close fd)
2377            (error "Couldn't create a file mapping - ~a." (%windows-error-string err)))
2378          (loop
2379            (let* ((base (#_VirtualAlloc (%null-ptr) nbytes #$MEM_RESERVE #$PAGE_NOACCESS)))
2380              (if (%null-ptr-p base)
2381                (let* ((err (#_GetLastError)))
2382                  (#_CloseHandle mapping)
2383                  (fd-close fd)
2384                  (error "Couldn't reserve ~d bytes of address space for mapped file - ~a"
2385                         nbytes (%windows-error-string err)))
2386                ;; Now we have to free the memory and hope that we can reallocate it ...
2387                (progn
2388                  (#_VirtualFree base 0 #$MEM_RELEASE)
2389                  (unless (%null-ptr-p (#_VirtualAlloc base *windows-allocation-granularity* #$MEM_RESERVE #$PAGE_NOACCESS))
2390                    (let* ((fptr (%inc-ptr base *windows-allocation-granularity*)))
2391                      (if (%null-ptr-p (#_MapViewOfFileEx mapping #$FILE_MAP_READ 0 0 0 fptr))
2392                        (#_VirtualFree base 0 #$MEM_RELEASE)
2393                        (let* ((prefix-page (%inc-ptr base (- *windows-allocation-granularity*
2394                                                              *host-page-size*))))
2395                          (#_VirtualAlloc prefix-page *host-page-size* #$MEM_COMMIT #$PAGE_READWRITE)
2396                          (setf (paref prefix-page (:* :address) 0) mapping
2397                                (paref prefix-page (:* :address) 1) (%int-to-ptr fd))
2398                          (return (values
2399                                   (%inc-ptr prefix-page (- *host-page-size*
2400                                                            (* 2 target::node-size)))
2401                                   ndata-elements
2402                                   nalignment-elements)))))))))))))))
2403                       
2404
2405
2406(defun map-file-to-ivector (pathname element-type)
2407  (let* ((upgraded-type (upgraded-array-element-type element-type))
2408         (upgraded-ctype (specifier-type upgraded-type)))
2409    (unless (and (typep upgraded-ctype 'numeric-ctype)
2410                 (eq 'integer (numeric-ctype-class upgraded-ctype)))
2411      (error "Invalid element-type: ~s" element-type))
2412    (let* ((bits-per-element (integer-length (- (numeric-ctype-high upgraded-ctype)
2413                                                (numeric-ctype-low upgraded-ctype))))
2414           (fd (fd-open (native-translated-namestring pathname) #$O_RDONLY)))
2415      (if (< fd 0)
2416        (signal-file-error fd pathname)
2417        (let* ((len (fd-size fd)))
2418          (if (< len 0)
2419            (signal-file-error fd pathname)
2420            (multiple-value-bind (header-address ndata-elements nalignment-elements)
2421                (%memory-map-fd fd len bits-per-element)
2422              (setf (%get-natural header-address 0)
2423                    (logior (element-type-subtype upgraded-type)
2424                            (ash (+ ndata-elements nalignment-elements) target::num-subtag-bits)))
2425              (with-macptrs ((v (%inc-ptr header-address target::fulltag-misc)))
2426                          (let* ((vector (rlet ((p :address v)) (%get-object p 0))))
2427                            ;; Tell some parts of Clozure CL - notably the
2428                            ;; printer - that this thing off in foreign
2429                            ;; memory is a real lisp object and not
2430                            ;; "bogus".
2431                            (with-lock-grabbed (*heap-ivector-lock*)
2432                              (push vector *heap-ivectors*))
2433                            (make-array ndata-elements
2434                                        :element-type upgraded-type
2435                                        :displaced-to vector
2436                                        :adjustable t
2437                                        :displaced-index-offset nalignment-elements))))))))))
2438
2439(defun map-file-to-octet-vector (pathname)
2440  (map-file-to-ivector pathname '(unsigned-byte 8)))
2441
2442(defun mapped-vector-data-address-and-size (displaced-vector)
2443  (let* ((v (array-displacement displaced-vector))
2444         (element-type (array-element-type displaced-vector)))
2445    (if (or (eq v displaced-vector)
2446            (not (with-lock-grabbed (*heap-ivector-lock*)
2447                   (member v *heap-ivectors*))))
2448      (error "~s doesn't seem to have been allocated via ~s and not yet unmapped" displaced-vector 'map-file-to-ivector))
2449    (let* ((pv (rlet ((x :address)) (%set-object x 0 v) (pref x :address)))
2450           (ctype (specifier-type element-type))
2451           (arch (backend-target-arch *target-backend*)))
2452      (values (%inc-ptr pv (- (* 2 target::node-size) target::fulltag-misc))
2453              (- (funcall (locally
2454                              ;; Don't really care about speed, but need to turn off typechecking for bootstrapping reasons
2455                              (declare (optimize (speed 3) (safety 0)))
2456                            (arch::target-array-data-size-function arch))
2457                          (ctype-subtype ctype)
2458                          (length v))
2459                 target::node-size)))))
2460
2461
2462#-windows-target
2463(defun %unmap-file (data-address size-in-octets)
2464  (let* ((base-address (%inc-ptr data-address (- *host-page-size*)))
2465         (fd (pref base-address :int)))
2466    (#_munmap base-address (+ *host-page-size* size-in-octets))
2467    (fd-close fd)))
2468
2469#+windows-target
2470(defun %unmap-file (data-address size-in-octets)
2471  (declare (ignore size-in-octets))
2472  (let* ((prefix-page (%inc-ptr data-address (- *host-page-size*)))
2473         (prefix-allocation (%inc-ptr data-address (- *windows-allocation-granularity*)))
2474         (mapping (paref prefix-page (:* :address) 0))
2475         (fd (%ptr-to-int (paref prefix-page (:* :address) 1))))
2476    (#_UnmapViewOfFile data-address)
2477    (#_CloseHandle mapping)
2478    (#_VirtualFree prefix-allocation 0 #$MEM_RELEASE)
2479    (fd-close fd)))
2480
2481   
2482
2483;;; Argument should be something returned by MAP-FILE-TO-IVECTOR;
2484;;; this should be called at most once for any such object.
2485(defun unmap-ivector (displaced-vector)
2486  (multiple-value-bind (data-address size-in-octets)
2487      (mapped-vector-data-address-and-size displaced-vector)
2488  (let* ((v (array-displacement displaced-vector)))
2489      (let* ((element-type (array-element-type displaced-vector)))
2490        (adjust-array displaced-vector 0
2491                      :element-type element-type
2492                      :displaced-to (make-array 0 :element-type element-type)
2493                      :displaced-index-offset 0))
2494      (with-lock-grabbed (*heap-ivector-lock*)
2495        (setq *heap-ivectors* (delete v *heap-ivectors*)))
2496      (%unmap-file data-address size-in-octets)
2497      t)))
2498
2499(defun unmap-octet-vector (v)
2500  (unmap-ivector v))
2501
2502#-windows-target
2503(progn
2504(defun lock-mapped-vector (v)
2505  (multiple-value-bind (address nbytes)
2506      (mapped-vector-data-address-and-size v)
2507    (eql 0 (#_mlock address nbytes))))
2508
2509(defun unlock-mapped-vector (v)
2510  (multiple-value-bind (address nbytes)
2511      (mapped-vector-data-address-and-size v)
2512    (eql 0 (#_munlock address nbytes))))
2513
2514(defun bitmap-for-mapped-range (address nbytes)
2515  (let* ((npages (ceiling nbytes *host-page-size*)))
2516    (%stack-block ((vec npages))
2517      (when (eql 0 (#_mincore address nbytes vec))
2518        (let* ((bits (make-array npages :element-type 'bit)))
2519          (dotimes (i npages bits)
2520            (setf (sbit bits i)
2521                  (logand 1 (%get-unsigned-byte vec i)))))))))
2522
2523(defun percentage-of-resident-pages (address nbytes)
2524  (let* ((npages (ceiling nbytes *host-page-size*)))
2525    (%stack-block ((vec npages))
2526      (when (eql 0 (#_mincore address nbytes vec))
2527        (let* ((nresident 0))
2528          (dotimes (i npages (* 100.0 (/ nresident npages)))
2529            (when (logbitp 0 (%get-unsigned-byte vec i))
2530              (incf nresident))))))))
2531
2532(defun mapped-vector-resident-pages (v)
2533  (multiple-value-bind (address nbytes)
2534      (mapped-vector-data-address-and-size v)
2535    (bitmap-for-mapped-range address nbytes)))
2536
2537(defun mapped-vector-resident-pages-percentage (v)
2538  (multiple-value-bind (address nbytes)
2539      (mapped-vector-data-address-and-size v)
2540    (percentage-of-resident-pages address nbytes)))
2541)
2542
2543
2544#+windows-target
2545(defun cygpath (winpath)
2546  "Try to use the Cygwin \"cygpath\" program to map a Windows-style
2547   pathname to a POSIX-stype Cygwin pathname."
2548  (let* ((posix-path winpath))
2549    (with-output-to-string (s)
2550      (multiple-value-bind (status exit-code)
2551          (external-process-status
2552           (run-program "cygpath" (list "-u" winpath) :output s))
2553        (when (and (eq status :exited)
2554                   (eql exit-code 0))
2555          (with-input-from-string (output (get-output-stream-string s))
2556            (setq posix-path (read-line output nil nil))))))
2557    posix-path))
2558
2559#-windows-target (defun cygpath (path) path)
2560     
2561
2562
2563
2564#+x86-target
2565(progn
2566(defloadvar *last-rdtsc-time* 0)
2567
2568(defstatic *rdtsc-estimated-increment* 1 "Should be positive ...")
2569
2570(defun rdtsc-monotonic ()
2571  "Return monotonically increasing values, partly compensating for
2572   OSes that don't keep the TSCs of all processorsin synch."
2573  (loop
2574    (let* ((old *last-rdtsc-time*)
2575           (new (rdtsc)))
2576      (when (< new old)
2577        ;; We're running on a CPU whose TSC is behind the one
2578        ;; on the last CPU we were scheduled on.
2579        (setq new (+ old *rdtsc-estimated-increment*)))
2580      (when (%store-node-conditional target::symbol.vcell *last-rdtsc-time* old new)
2581        (return new)))))
2582
2583(defun estimate-rdtsc-skew (&optional (niter 1000000))
2584  (do* ((i 0 (1+ i))
2585        (last (rdtsc) next)
2586        (next (rdtsc) (rdtsc))
2587        (skew 1))
2588       ((>= i niter) (setq *rdtsc-estimated-increment* skew))
2589    (declare (fixnum last next skew))
2590    (when (> last next)
2591      (let* ((s (- last next)))
2592        (declare (fixnum s))
2593        (when (> s skew) (setq skew s))))))
2594)
2595
2596
Note: See TracBrowser for help on using the repository browser.