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

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

SAME-FD-P on Windows: don't use RLET so early in the loading sequence.

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