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

Last change on this file since 10825 was 10825, checked in by gb, 11 years ago

Try to work around the fact that the mingw headers on Windows
define the fields of "timeval" structures to be signed.

Tentatively prefer "HOME" (Cygwn) to "USERPROFILE" as an env var
that points to the user's home directory, then back out of that
(there are issues related to getting CCL and XEmacs to agree
on where "home" should be.)

When waiting on an external process, try to make the wait
"alertable"; continue the infinite wait if we got an interrupt
while waiting.

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