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

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

Fix Windows lossage from last commit.

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