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

Last change on this file was 16801, checked in by svspire, 3 years ago

Fix broken build. Apparently linux and solaris don't define the st_flags field.

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