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

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

FD-FSYNC: Call #_FlushFileBuffers with a handle, not a pseudo fd.

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