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

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

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

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