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

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

Use #_forkall (clone all threads in the child process), not just #_fork
on Solaris. (Apparently, when Solaris doesn't clone a thread, it doesn't
clone its stack, either; the recently-merged change that creates the
string vector (argv) in the calling thread rather than in the monitor
thread exposes this.)

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