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

Last change on this file since 14646 was 14646, checked in by gb, 9 years ago

Fix Windows lossage from last commit.

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