source: branches/working-0711/ccl/level-1/linux-files.lisp @ 11089

Last change on this file since 11089 was 11089, checked in by gz, 13 years ago

Merge/bootstrap assorted low level stuff from trunk - kernel, syscall stuff, lowmem-bias, formatting tweaks, a few bug fixes included

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 77.9 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 (#_fork)))
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
1236(defun run-program (program args &key
1237                            (wait t) pty
1238                            input if-input-does-not-exist
1239                            output (if-output-exists :error)
1240                            (error :output) (if-error-exists :error)
1241                            status-hook (element-type 'character)
1242                            env
1243                            (silently-ignore-catastrophic-failures
1244                             *silently-ignore-catastrophic-failure-in-run-program*))
1245  "Invoke an external program as an OS subprocess of lisp."
1246  (declare (ignore pty))
1247  (unless (every #'(lambda (a) (typep a 'simple-string)) args)
1248    (error "Program args must all be simple strings : ~s" args))
1249  (dolist (pair env)
1250    (destructuring-bind (var . val) pair
1251      (assert (typep var '(or string symbol character)))
1252      (assert (typep val 'string)))) 
1253  (push (native-untranslated-namestring program) args)
1254  (let* ((token (list 0))
1255         (in-fd nil)
1256         (in-stream nil)
1257         (out-fd nil)
1258         (out-stream nil)
1259         (error-fd nil)
1260         (error-stream nil)
1261         (close-in-parent nil)
1262         (close-on-error nil)
1263         (proc
1264          (make-external-process
1265           :pid nil
1266           :args args
1267           :%status :running
1268           :input nil
1269           :output nil
1270           :error nil
1271           :token token
1272           :status-hook status-hook)))
1273    (unwind-protect
1274         (progn
1275           (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
1276             (get-descriptor-for input proc  nil nil :direction :input
1277                                 :if-does-not-exist if-input-does-not-exist
1278                                 :element-type element-type))
1279           (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
1280             (get-descriptor-for output proc close-in-parent close-on-error
1281                                 :direction :output
1282                                 :if-exists if-output-exists
1283                                 :element-type element-type))
1284           (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
1285             (if (eq error :output)
1286               (values out-fd out-stream close-in-parent close-on-error)
1287               (get-descriptor-for error proc close-in-parent close-on-error
1288                                   :direction :output
1289                                   :if-exists if-error-exists
1290                                   :element-type element-type)))
1291           (setf (external-process-input proc) in-stream
1292                 (external-process-output proc) out-stream
1293                 (external-process-error proc) error-stream)
1294           (call-with-string-vector
1295            #'(lambda (argv)
1296                (process-run-function
1297                 (format nil "Monitor thread for external process ~a" args)
1298                 #'run-external-process proc in-fd out-fd error-fd argv env)
1299                (wait-on-semaphore (external-process-signal proc)))
1300              args)))
1301      (dolist (fd close-in-parent) (fd-close fd))
1302      (unless (external-process-pid proc)
1303        (dolist (fd close-on-error) (fd-close fd)))
1304      (when (and wait (external-process-pid proc))
1305        (with-interrupts-enabled
1306            (wait-on-semaphore (external-process-completed proc))))
1307    (if (eq (external-process-%status proc) :error)
1308      (if silently-ignore-catastrophic-failures
1309        proc
1310        (error 'external-process-creation-failure proc))
1311      (and (external-process-pid proc) proc))))
1312
1313
1314
1315
1316(defmacro wifsignaled (status)
1317  (let* ((statname (gensym)))
1318    `(let* ((,statname ,status))
1319      (and (not (wifstopped ,statname)) (not (wifexited ,statname))))))
1320
1321
1322(defun check-pid (pid &optional (flags (logior  #$WNOHANG #$WUNTRACED)))
1323  (declare (fixnum pid))
1324  (rlet ((status :signed))
1325    (let* ((retval (ff-call-ignoring-eintr (#_waitpid pid status flags))))
1326      (declare (fixnum retval))
1327      (if (= retval pid)
1328        (pref status :signed)
1329        (zerop retval)))))
1330
1331
1332
1333
1334
1335(defun external-process-wait (proc &optional check-stopped)
1336  (process-wait "external-process-wait"
1337                #'(lambda ()
1338                    (case (external-process-%status proc)
1339                      (:running)
1340                      (:stopped
1341                       (when check-stopped
1342                         t))
1343                      (t
1344                       (when (zerop (car (external-process-token proc)))
1345                         t))))))
1346
1347(defun external-process-status (proc)
1348  "Return information about whether an OS subprocess is running; or, if
1349not, why not; and what its result code was if it completed."
1350  (require-type proc 'external-process)
1351  (values (external-process-%status proc)
1352          (external-process-%exit-code proc)))
1353
1354(defun external-process-input-stream (proc)
1355  "Return the lisp stream which is used to write input to a given OS
1356subprocess, if it has one."
1357  (require-type proc 'external-process)
1358  (external-process-input proc))
1359
1360(defun external-process-output-stream (proc)
1361  "Return the lisp stream which is used to read output from a given OS
1362subprocess, if there is one."
1363  (require-type proc 'external-process)
1364  (external-process-output proc))
1365
1366(defun external-process-error-stream (proc)
1367  "Return the stream which is used to read error output from a given OS
1368subprocess, if it has one."
1369  (require-type proc 'external-process)
1370  (external-process-error proc))
1371
1372(defun external-process-id (proc)
1373  "Return the process id of an OS subprocess, a positive integer which
1374identifies it."
1375  (require-type proc 'external-process)
1376  (external-process-pid proc))
1377 
1378(defun signal-external-process (proc signal)
1379  "Send the specified signal to the specified external process.  (Typically,
1380it would only be useful to call this function if the EXTERNAL-PROCESS was
1381created with :WAIT NIL.) Return T if successful, NIL if the process wasn't
1382created successfully, and signal an error otherwise."
1383  (require-type proc 'external-process)
1384  (let* ((pid (external-process-pid proc)))
1385    (when pid
1386      (let* ((error (int-errno-call (#_kill pid signal))))
1387        (or (eql error 0)
1388            (%errno-disp error))))))
1389
1390) ; #-windows-target (progn
1391
1392#+windows-target
1393(progn
1394(defun temp-file-name (prefix)
1395  "Returns a unique name for a temporary file, residing in system temp
1396space, and prefixed with PREFIX."
1397  (rlet ((buffer (:array :wchar_t #.#$MAX_PATH)))
1398    (#_GetTempPathW #$MAX_PATH buffer)
1399    (with-filename-cstrs ((c-prefix prefix)) 
1400      (#_GetTempFileNameW buffer c-prefix 0 buffer)
1401      (%get-native-utf-16-cstring buffer))))
1402 
1403(defun get-descriptor-for (object proc close-in-parent close-on-error
1404                                  &rest keys &key direction (element-type 'character)
1405                                  &allow-other-keys)
1406  (etypecase object
1407    ((eql t)
1408     (values nil nil close-in-parent close-on-error))
1409    (null
1410     (let* ((null-device "nul")
1411            (fd (fd-open null-device (case direction
1412                                       (:input #$O_RDONLY)
1413                                       (:output #$O_WRONLY)
1414                                       (t #$O_RDWR)))))
1415       (if (< fd 0)
1416         (signal-file-error fd null-device))
1417       (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
1418    ((eql :stream)
1419     (multiple-value-bind (read-pipe write-pipe) (pipe)
1420       (case direction
1421         (:input
1422          (values read-pipe
1423                  (make-fd-stream (fd-uninheritable write-pipe :direction :output)
1424                                  :direction :output
1425                                  :element-type element-type
1426                                  :interactive nil
1427                                  :basic t
1428                                  :auto-close t)
1429                  (cons read-pipe close-in-parent)
1430                  (cons write-pipe close-on-error)))
1431         (:output
1432          (values write-pipe
1433                  (make-fd-stream (fd-uninheritable read-pipe :direction :input)
1434                                  :direction :input
1435                                  :element-type element-type
1436                                  :interactive nil
1437                                  :basic t
1438                                  :auto-close t)
1439                  (cons write-pipe close-in-parent)
1440                  (cons read-pipe close-on-error)))
1441         (t
1442          (fd-close read-pipe)
1443          (fd-close write-pipe)
1444          (report-bad-arg direction '(member :input :output))))))
1445    ((or pathname string)
1446     (with-open-stream (file (apply #'open object keys))
1447       (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)) :direction direction :inheritable t)))
1448         (values fd
1449                 nil
1450                 (cons fd close-in-parent)
1451                 (cons fd close-on-error)))))
1452    (fd-stream
1453     (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
1454       (values fd
1455               nil
1456               (cons fd close-in-parent)
1457               (cons fd close-on-error))))
1458    (stream
1459     (ecase direction
1460       (:input
1461        (let* ((tempname (temp-file-name "lisp-temp"))
1462               (fd (fd-open tempname #$O_RDWR)))
1463          (if (< fd 0)
1464            (%errno-disp fd))
1465          (loop
1466            (multiple-value-bind (line no-newline)
1467                (read-line object nil nil)
1468              (unless line
1469                (return))
1470              (let* ((len (length line)))
1471                (%stack-block ((buf (1+ len)))
1472                  (%cstr-pointer line buf)
1473                  (fd-write fd buf len)
1474                  (if no-newline
1475                    (return))
1476                  (setf (%get-byte buf) (char-code #\newline))
1477                  (fd-write fd buf 1)))))
1478          (fd-lseek fd 0 #$SEEK_SET)
1479          (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
1480       (:output
1481        (multiple-value-bind (read-pipe write-pipe) (pipe)
1482          (setf (external-process-watched-fd proc) read-pipe
1483                (external-process-watched-stream proc) object)
1484          (incf (car (external-process-token proc)))
1485          (values write-pipe
1486                  nil
1487                  (cons write-pipe close-in-parent)
1488                  (cons read-pipe close-on-error))))))))
1489
1490(defstruct external-process
1491  pid
1492  %status
1493  %exit-code
1494  pty
1495  input
1496  output
1497  error
1498  status-hook
1499  plist
1500  token
1501  core
1502  args
1503  (signal (make-semaphore))
1504  (completed (make-semaphore))
1505  watched-fd
1506  watched-stream
1507  )
1508
1509(defun external-process-status (proc)
1510  "Return information about whether an OS subprocess is running; or, if
1511not, why not; and what its result code was if it completed."
1512  (require-type proc 'external-process)
1513  (values (external-process-%status proc)
1514          (external-process-%exit-code proc)))
1515
1516
1517(defmethod print-object ((p external-process) stream)
1518  (print-unreadable-object (p stream :type t :identity t)
1519    (let* ((status (external-process-%status p)))
1520      (let* ((*print-length* 3))
1521        (format stream "~a" (external-process-args p)))
1522      (format stream "[~d] (~a" (external-process-pid p) status)
1523      (unless (eq status :running)
1524        (format stream " : ~d" (external-process-%exit-code p)))
1525      (format stream ")"))))
1526
1527(defun run-program (program args &key
1528                            (wait t) pty
1529                            input if-input-does-not-exist
1530                            output (if-output-exists :error)
1531                            (error :output) (if-error-exists :error)
1532                            status-hook (element-type 'character)
1533                            env)
1534  "Invoke an external program as an OS subprocess of lisp."
1535  (declare (ignore pty))
1536  (unless (every #'(lambda (a) (typep a 'simple-string)) args)
1537    (error "Program args must all be simple strings : ~s" args))
1538  (push program args)
1539  (let* ((token (list 0))
1540         (in-fd nil)
1541         (in-stream nil)
1542         (out-fd nil)
1543         (out-stream nil)
1544         (error-fd nil)
1545         (error-stream nil)
1546         (close-in-parent nil)
1547         (close-on-error nil)
1548         (proc
1549          (make-external-process
1550           :pid nil
1551           :args args
1552           :%status :running
1553           :input nil
1554           :output nil
1555           :error nil
1556           :token token
1557           :status-hook status-hook)))
1558    (unwind-protect
1559         (progn
1560           (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
1561             (get-descriptor-for input proc  nil nil :direction :input
1562                                 :if-does-not-exist if-input-does-not-exist
1563                                 :element-type element-type))
1564           (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
1565             (get-descriptor-for output proc close-in-parent close-on-error
1566                                 :direction :output
1567                                 :if-exists if-output-exists
1568                                 :element-type element-type))
1569           (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
1570             (if (eq error :output)
1571               (values out-fd out-stream close-in-parent close-on-error)
1572               (get-descriptor-for error proc close-in-parent close-on-error
1573                                   :direction :output
1574                                   :if-exists if-error-exists
1575                                   :element-type element-type)))
1576           (setf (external-process-input proc) in-stream
1577                 (external-process-output proc) out-stream
1578                 (external-process-error proc) error-stream)
1579           (process-run-function
1580            (format nil "Monitor thread for external process ~a" args)
1581                   
1582            #'run-external-process proc in-fd out-fd error-fd env)
1583           (wait-on-semaphore (external-process-signal proc))
1584           )
1585      (dolist (fd close-in-parent) (fd-close fd))
1586      (if (external-process-pid proc)
1587        (when (and wait (external-process-pid proc))
1588          (with-interrupts-enabled
1589              (wait-on-semaphore (external-process-completed proc))))
1590        (progn
1591          (dolist (fd close-on-error) (fd-close fd))
1592          (error "Process execution failed"))))
1593    proc))
1594
1595(let* ((external-processes ())
1596       (external-processes-lock (make-lock)))
1597  (defun add-external-process (p)
1598    (with-lock-grabbed (external-processes-lock)
1599      (push p external-processes)))
1600  (defun remove-external-process (p)
1601    (with-lock-grabbed (external-processes-lock)
1602      (setq external-processes (delete p external-processes))))
1603  ;; Likewise
1604  (defun external-processes ()
1605    (with-lock-grabbed (external-processes-lock)
1606      (copy-list external-processes)))
1607  )
1608
1609
1610
1611
1612(defun run-external-process (proc in-fd out-fd error-fd &optional env)
1613  (let* ((args (external-process-args proc))
1614         (child-pid (exec-with-io-redirection in-fd out-fd error-fd args proc env)))
1615    (when child-pid
1616      (setf (external-process-pid proc) child-pid)
1617      (add-external-process proc)
1618      (signal-semaphore (external-process-signal proc))
1619      (monitor-external-process proc))))
1620
1621(defun join-strings (strings)
1622  (reduce (lambda (left right) (concatenate 'string left " " right)) strings))
1623
1624(defun exec-with-io-redirection (new-in new-out new-err args proc &optional env)
1625  (declare (ignore env))                ; until we can do better.
1626  (with-filename-cstrs ((command (join-strings args)))
1627    (rletz ((proc-info #>PROCESS_INFORMATION)
1628            (si #>STARTUPINFO))
1629      (setf (pref si #>STARTUPINFO.cb) (record-length #>STARTUPINFO))
1630      (setf (pref si #>STARTUPINFO.dwFlags)
1631            (logior #$STARTF_USESTDHANDLES #$STARTF_USESHOWWINDOW))
1632      (setf (pref si #>STARTUPINFO.wShowWindow) #$SW_HIDE)
1633      (setf (pref si #>STARTUPINFO.hStdInput)
1634            (if new-in
1635              (%int-to-ptr new-in)
1636              (#_GetStdHandle #$STD_INPUT_HANDLE)))
1637      (setf (pref si #>STARTUPINFO.hStdOutput)
1638            (if new-out
1639              (%int-to-ptr new-out)
1640              (#_GetStdHandle #$STD_OUTPUT_HANDLE)))
1641      (setf (pref si #>STARTUPINFO.hStdError)
1642            (if new-err
1643              (%int-to-ptr new-err)
1644              (#_GetStdHandle #$STD_ERROR_HANDLE)))
1645      (if (zerop (#_CreateProcessW (%null-ptr)
1646                                   command
1647                                   (%null-ptr)
1648                                   (%null-ptr)
1649                                   1
1650                                   #$CREATE_NEW_CONSOLE
1651                                   (%null-ptr)
1652                                   (%null-ptr)
1653                                   si
1654                                   proc-info))
1655        (setf (external-process-%status proc) :error
1656              (external-process-%exit-code proc) (#_GetLastError))
1657        (#_CloseHandle (pref proc-info #>PROCESS_INFORMATION.hThread)))
1658      (pref proc-info #>PROCESS_INFORMATION.hProcess))))
1659
1660(defun fd-uninheritable (fd &key direction)
1661  (let ((new-fd (fd-dup fd :direction direction)))
1662    (fd-close fd)
1663    new-fd))
1664
1665(defun monitor-external-process (p)
1666  (let* ((in-fd (external-process-watched-fd p))
1667         (out-stream (external-process-watched-stream p))
1668         (token (external-process-token p))
1669         (terminated))
1670    (loop
1671      (when terminated
1672        (without-interrupts
1673         (decf (car token))
1674         (if in-fd (fd-close in-fd))
1675         (setq in-fd nil)
1676         (rlet ((code #>DWORD))
1677           (loop
1678             (#_GetExitCodeProcess (external-process-pid p) code)
1679             (unless (eql (pref code #>DWORD) #$STILL_ACTIVE)
1680               (return)))
1681           (#_SleepEx 10 #$TRUE)
1682           (setf (external-process-%exit-code p) (pref code #>DWORD)))
1683         (#_CloseHandle (external-process-pid p))
1684         (setf (external-process-pid p) nil)
1685         (setf (external-process-%status p) :exited)
1686         (let ((status-hook (external-process-status-hook p)))
1687           (when status-hook
1688             (funcall status-hook p)))
1689         (remove-external-process p)
1690         (signal-semaphore (external-process-completed p))
1691         (return)))     
1692      (if in-fd
1693        (rlet ((handles (:array #>HANDLE 2)))
1694          (setf (paref handles (:array #>HANDLE) 0) (external-process-pid p))
1695          (setf (paref handles (:array #>HANDLE) 1) (#__get_osfhandle in-fd))
1696          (let ((rc (ignoring-eintr
1697                     (let* ((code (#_WaitForMultipleObjectsEx 2 handles #$FALSE #$INFINITE #$true)))
1698                       (if (eql code #$WAIT_IO_COMPLETION)
1699                         (- #$EINTR)
1700                         code)))))
1701            (if (eq rc #$WAIT_OBJECT_0)
1702              (setf terminated t)
1703              (%stack-block ((buf 1024))
1704                (let* ((n (fd-read in-fd buf 1024)))
1705                  (declare (fixnum n))
1706                  (if (<= n 0)
1707                    (setf terminated t)
1708                    (let* ((string (make-string 1024)))
1709                      (declare (dynamic-extent string))
1710                      (%str-from-ptr buf n string)
1711                      (write-sequence string out-stream :end n))))))))
1712        (progn
1713          (ignoring-eintr
1714           (let* ((code (#_WaitForSingleObjectEx (external-process-pid p) #$INFINITE #$true)))
1715             (if (eql code #$WAIT_IO_COMPLETION)
1716               (- #$EINTR)
1717               code)))
1718          (setf terminated t))))))
1719 
1720
1721)                                   ; #+windows-target (progn
1722
1723;;; EOF on a TTY is transient, but I'm less sure of other cases.
1724(defun eof-transient-p (fd)
1725  (case (%unix-fd-kind fd)
1726    (:tty t)
1727    #+windows-target (:character-special t)
1728    (t nil)))
1729
1730
1731(defstruct (shared-resource (:constructor make-shared-resource (name)))
1732  (name)
1733  (lock (make-lock))
1734  (primary-owner *current-process*)
1735  (primary-owner-notify (make-semaphore))
1736  (current-owner nil)
1737  (requestors (make-dll-header)))
1738
1739(defstruct (shared-resource-request
1740             (:constructor make-shared-resource-request (process))
1741             (:include dll-node))
1742  process
1743  (signal (make-semaphore)))
1744             
1745
1746;; Returns NIL if already owned by calling thread, T otherwise
1747(defun %acquire-shared-resource (resource  &optional verbose)
1748  (let* ((current *current-process*))
1749    (with-lock-grabbed ((shared-resource-lock resource))
1750      (let* ((secondary (shared-resource-current-owner resource)))
1751        (if (or (eq current secondary)
1752                (and (null secondary)
1753                     (eq current (shared-resource-primary-owner resource))))
1754          (return-from %acquire-shared-resource nil))))
1755    (let* ((request (make-shared-resource-request *current-process*)))
1756      (when verbose
1757        (format t "~%~%;;;~%;;; ~a requires access to ~a~%;;; Type (:y ~D) to yield control to this thread.~%;;;~%"
1758                *current-process* (shared-resource-name resource)
1759                (process-serial-number *current-process*)))
1760      (with-lock-grabbed ((shared-resource-lock resource))
1761        (append-dll-node request (shared-resource-requestors resource)))
1762      (wait-on-semaphore (shared-resource-request-signal request))
1763      (assert (eq current (shared-resource-current-owner resource)))
1764      (when verbose
1765        (format t "~%~%;;;~%;;; ~a is now owned by ~a~%;;;~%~%"
1766                (shared-resource-name resource) current))
1767      t)))
1768
1769;;; If we're the primary owner and there is no secondary owner, do nothing.
1770;;; If we're the secondary owner, cease being the secondary owner.
1771(defun %release-shared-resource (r)
1772  (let* ((not-any-owner ()))
1773    (with-lock-grabbed ((shared-resource-lock r))
1774      (let* ((current *current-process*)
1775             (primary (shared-resource-primary-owner r))
1776             (secondary (shared-resource-current-owner r)))
1777        (unless (setq not-any-owner
1778                      (not (or (eq current secondary)
1779                               (and (null secondary)
1780                                    (eq current primary)))))
1781          (when (eq current secondary)
1782            (setf (shared-resource-current-owner r) nil)
1783            (signal-semaphore (shared-resource-primary-owner-notify r))))))
1784    (when not-any-owner
1785      (signal-program-error "Process ~a does not own ~a" *current-process*
1786                            (shared-resource-name r)))))
1787
1788;;; The current thread should be the primary owner; there should be
1789;;; no secondary owner.  Wakeup the specified (or first) requesting
1790;;; process, then block on our semaphore
1791(defun %yield-shared-resource (r &optional to)
1792  (let* ((request nil))
1793    (with-lock-grabbed ((shared-resource-lock r))
1794      (let* ((current *current-process*)
1795             (primary (shared-resource-primary-owner r)))
1796        (when (and (eq current primary)
1797                   (null (shared-resource-current-owner r)))
1798          (setq request
1799                (let* ((header (shared-resource-requestors r)))
1800                  (if to 
1801                    (do-dll-nodes (node header)
1802                      (when (eq to (shared-resource-request-process node))
1803                        (return node)))
1804                    (let* ((first (dll-header-first header)))
1805                      (unless (eq first header)
1806                        first)))))
1807          (when request
1808            (remove-dll-node request)
1809            (setf (shared-resource-current-owner r)
1810                  (shared-resource-request-process request))
1811            (signal-semaphore (shared-resource-request-signal request))))))
1812    (when request
1813      (wait-on-semaphore (shared-resource-primary-owner-notify r))
1814      (format t "~%;;;~%;;;control of ~a restored to ~a~%;;;~&"
1815              (shared-resource-name r)
1816              *current-process*))))
1817
1818
1819     
1820
1821(defun %shared-resource-requestor-p (r proc)
1822  (with-lock-grabbed ((shared-resource-lock r))
1823    (do-dll-nodes (node (shared-resource-requestors r))
1824      (when (eq proc (shared-resource-request-process node))
1825        (return t)))))
1826
1827(defparameter *resident-editor-hook* nil
1828  "If non-NIL, should be a function that takes an optional argument
1829   (like ED) and invokes a \"resident\" editor.")
1830
1831(defun ed (&optional arg)
1832  (if *resident-editor-hook*
1833    (funcall *resident-editor-hook* arg)
1834    (error "This implementation doesn't provide a resident editor.")))
1835
1836(defun running-under-emacs-p ()
1837  (not (null (getenv "EMACS"))))
1838
1839(defloadvar *cpu-count* nil)
1840
1841(defun cpu-count ()
1842  (or *cpu-count*
1843      (setq *cpu-count*
1844            #+darwin-target
1845            (rlet ((info :host_basic_info)
1846                   (count :mach_msg_type_number_t #$HOST_BASIC_INFO_COUNT))
1847              (if (eql #$KERN_SUCCESS (#_host_info (#_mach_host_self)
1848                                                   #$HOST_BASIC_INFO
1849                                                   info
1850                                                   count))
1851                (pref info :host_basic_info.max_cpus)
1852                1))
1853            #+(or linux-target solaris-target)
1854            (or
1855             (let* ((n (#_sysconf #$_SC_NPROCESSORS_ONLN)))
1856               (declare (fixnum n))
1857               (if (> n 0) n))
1858             #+linux-target
1859             (ignore-errors
1860               (with-open-file (p "/proc/cpuinfo")
1861                 (let* ((ncpu 0)
1862                        (match "processor")
1863                        (matchlen (length match)))
1864                   (do* ((line (read-line p nil nil) (read-line p nil nil)))
1865                        ((null line) ncpu)
1866                     (let* ((line-length (length line)))
1867                       (when (and
1868                              (> line-length matchlen)
1869                              (string= match line
1870                                       :end2 matchlen)
1871                              (whitespacep (schar line matchlen)))
1872                         (incf ncpu)))))))
1873             1)
1874            #+freebsd-target
1875            (rlet ((ret :uint))
1876              (%stack-block ((mib (* (record-length :uint) 2)))
1877              (setf (paref mib (:array :uint) 0)
1878                    #$CTL_HW
1879                    (paref mib (:array :uint) 1)
1880                    #$HW_NCPU)
1881              (rlet ((oldsize :uint (record-length :uint)))
1882                (if (eql 0 (#_sysctl mib 2 ret oldsize (%null-ptr) 0))
1883                  (pref ret :uint)
1884                  1))))
1885            #+windows-target
1886            (rlet ((procmask #>DWORD_PTR)
1887                   (sysmask #>DWORD_PTR))
1888              (if (eql 0 (#_GetProcessAffinityMask (#_GetCurrentProcess) procmask sysmask))
1889                1
1890                (logcount (pref sysmask #>DWORD_PTR)))))))
1891
1892(def-load-pointers spin-count ()
1893  (if (eql 1 (cpu-count))
1894    (%defglobal '*spin-lock-tries* 1)
1895    (%defglobal '*spin-lock-tries* 1024))
1896  (%defglobal '*spin-lock-timeouts* 0))
1897
1898(defun yield ()
1899  #+windows-target
1900  (#_Sleep 0)
1901  #-windows-target 
1902  (#_sched_yield))
1903
1904(defloadvar *host-page-size*
1905    #-windows-target (#_getpagesize)
1906    #+windows-target
1907    (rlet ((info #>SYSTEM_INFO))
1908      (#_GetSystemInfo info)
1909      (pref info #>SYSTEM_INFO.dwPageSize))
1910    )
1911
1912;;(assert (= (logcount *host-page-size*) 1))
1913
1914(defun get-universal-time ()
1915  "Return a single integer for the current time of
1916   day in universal time format."
1917  (rlet ((tv :timeval))
1918    (gettimeofday tv)
1919    (+ (pref tv :timeval.tv_sec) unix-to-universal-time)))
1920
1921#-windows-target
1922(progn
1923(defun map-file-to-ivector (pathname element-type)
1924  (let* ((upgraded-type (upgraded-array-element-type element-type))
1925         (upgraded-ctype (specifier-type upgraded-type)))
1926    (unless (and (typep upgraded-ctype 'numeric-ctype)
1927                 (eq 'integer (numeric-ctype-class upgraded-ctype)))
1928      (error "Invalid element-type: ~s" element-type))
1929    (let* ((bits-per-element (integer-length (- (numeric-ctype-high upgraded-ctype)
1930                                                (numeric-ctype-low upgraded-ctype))))
1931           (fd (fd-open (native-translated-namestring pathname) #$O_RDONLY)))
1932      (if (< fd 0)
1933        (signal-file-error fd pathname)
1934        (let* ((len (fd-size fd)))
1935          (if (< len 0)
1936            (signal-file-error fd pathname)
1937            (let* ((nbytes (+ *host-page-size*
1938                              (logandc2 (+ len
1939                                           (1- *host-page-size*))
1940                                        (1- *host-page-size*))))
1941
1942                   (ndata-elements
1943                    (ash len
1944                         (ecase bits-per-element
1945                           (1 3)
1946                           (8 0)
1947                           (16 -1)
1948                           (32 -2)
1949                           (64 -3))))
1950                   (nalignment-elements
1951                    (ash target::nbits-in-word
1952                         (ecase bits-per-element
1953                           (1 0)
1954                           (8 -3)
1955                           (16 -4)
1956                           (32 -5)
1957                           (64 -6)))))
1958              (if (>= (+ ndata-elements nalignment-elements)
1959                      array-total-size-limit)
1960                (progn
1961                  (fd-close fd)
1962                  (error "Can't make a vector with ~s elements in this implementation." (+ ndata-elements nalignment-elements)))
1963                (let* ((addr (#_mmap (%null-ptr)
1964                                     nbytes
1965                                     #$PROT_NONE
1966                                     (logior #$MAP_ANON #$MAP_PRIVATE)
1967                                     -1
1968                                     0)))             
1969                  (if (eql addr (%int-to-ptr (1- (ash 1 target::nbits-in-word)))) ; #$MAP_FAILED
1970                    (let* ((errno (%get-errno)))
1971                      (fd-close fd)
1972                      (error "Can't map ~d bytes: ~a" nbytes (%strerror errno)))
1973              ;;; Remap the first page so that we can put a vector header
1974              ;;; there; use the first word on the first page to remember
1975              ;;; the file descriptor.
1976                    (progn
1977                      (#_mmap addr
1978                              *host-page-size*
1979                              (logior #$PROT_READ #$PROT_WRITE)
1980                              (logior #$MAP_ANON #$MAP_PRIVATE #$MAP_FIXED)
1981                              -1
1982                              0)
1983                      (setf (pref addr :int) fd)
1984                      (let* ((header-addr (%inc-ptr addr (- *host-page-size*
1985                                                            (* 2 target::node-size)))))
1986                        (setf (pref header-addr :unsigned-long)
1987                              (logior (element-type-subtype upgraded-type)
1988                                      (ash (+ ndata-elements nalignment-elements) target::num-subtag-bits)))
1989                        (when (> len 0)
1990                          (let* ((target-addr (%inc-ptr header-addr (* 2 target::node-size))))
1991                            (unless (eql target-addr
1992                                         (#_mmap target-addr
1993                                                 len
1994                                                 #$PROT_READ
1995                                                 (logior #$MAP_PRIVATE #$MAP_FIXED)
1996                                                 fd
1997                                                 0))
1998                              (let* ((errno (%get-errno)))
1999                                (fd-close fd)
2000                                (#_munmap addr nbytes)
2001                                (error "Mapping failed: ~a" (%strerror errno))))))
2002                        (with-macptrs ((v (%inc-ptr header-addr target::fulltag-misc)))
2003                          (let* ((vector (rlet ((p :address v)) (%get-object p 0))))
2004                            ;; Tell some parts of OpenMCL - notably the
2005                            ;; printer - that this thing off in foreign
2006                            ;; memory is a real lisp object and not
2007                            ;; "bogus".
2008                            (with-lock-grabbed (*heap-ivector-lock*)
2009                              (push vector *heap-ivectors*))
2010                            (make-array ndata-elements
2011                                        :element-type upgraded-type
2012                                        :displaced-to vector
2013                                        :adjustable t
2014                                        :displaced-index-offset nalignment-elements)))))))))))))))
2015
2016(defun map-file-to-octet-vector (pathname)
2017  (map-file-to-ivector pathname '(unsigned-byte 8)))
2018
2019(defun mapped-vector-data-address-and-size (displaced-vector)
2020  (let* ((v (array-displacement displaced-vector))
2021         (element-type (array-element-type displaced-vector)))
2022    (if (or (eq v displaced-vector)
2023            (not (with-lock-grabbed (*heap-ivector-lock*)
2024                   (member v *heap-ivectors*))))
2025      (error "~s doesn't seem to have been allocated via ~s and not yet unmapped" displaced-vector 'map-file-to-ivector))
2026    (let* ((pv (rlet ((x :address)) (%set-object x 0 v) (pref x :address)))
2027           (ctype (specifier-type element-type))
2028           (arch (backend-target-arch *target-backend*)))
2029      (values (%inc-ptr pv (- (* 2 target::node-size) target::fulltag-misc))
2030              (- (funcall (arch::target-array-data-size-function arch)
2031                          (ctype-subtype ctype)
2032                          (length v))
2033                 target::node-size)))))
2034
2035 
2036;;; Argument should be something returned by MAP-FILE-TO-IVECTOR;
2037;;; this should be called at most once for any such object.
2038(defun unmap-ivector (displaced-vector)
2039  (multiple-value-bind (data-address size-in-octets)
2040      (mapped-vector-data-address-and-size displaced-vector)
2041  (let* ((v (array-displacement displaced-vector))
2042         (base-address (%inc-ptr data-address (- *host-page-size*)))
2043         (fd (pref base-address :int)))
2044      (let* ((element-type (array-element-type displaced-vector)))
2045        (adjust-array displaced-vector 0
2046                      :element-type element-type
2047                      :displaced-to (make-array 0 :element-type element-type)
2048                      :displaced-index-offset 0))
2049      (with-lock-grabbed (*heap-ivector-lock*)
2050        (setq *heap-ivectors* (delete v *heap-ivectors*)))
2051      (#_munmap base-address (+ size-in-octets *host-page-size*))     
2052      (fd-close fd)
2053      t)))
2054
2055(defun unmap-octet-vector (v)
2056  (unmap-ivector v))
2057
2058(defun lock-mapped-vector (v)
2059  (multiple-value-bind (address nbytes)
2060      (mapped-vector-data-address-and-size v)
2061    (eql 0 (#_mlock address nbytes))))
2062
2063(defun unlock-mapped-vector (v)
2064  (multiple-value-bind (address nbytes)
2065      (mapped-vector-data-address-and-size v)
2066    (eql 0 (#_munlock address nbytes))))
2067
2068(defun bitmap-for-mapped-range (address nbytes)
2069  (let* ((npages (ceiling nbytes *host-page-size*)))
2070    (%stack-block ((vec npages))
2071      (when (eql 0 (#_mincore address nbytes vec))
2072        (let* ((bits (make-array npages :element-type 'bit)))
2073          (dotimes (i npages bits)
2074            (setf (sbit bits i)
2075                  (logand 1 (%get-unsigned-byte vec i)))))))))
2076
2077(defun percentage-of-resident-pages (address nbytes)
2078  (let* ((npages (ceiling nbytes *host-page-size*)))
2079    (%stack-block ((vec npages))
2080      (when (eql 0 (#_mincore address nbytes vec))
2081        (let* ((nresident 0))
2082          (dotimes (i npages (* 100.0 (/ nresident npages)))
2083            (when (logbitp 0 (%get-unsigned-byte vec i))
2084              (incf nresident))))))))
2085
2086(defun mapped-vector-resident-pages (v)
2087  (multiple-value-bind (address nbytes)
2088      (mapped-vector-data-address-and-size v)
2089    (bitmap-for-mapped-range address nbytes)))
2090
2091(defun mapped-vector-resident-pages-percentage (v)
2092  (multiple-value-bind (address nbytes)
2093      (mapped-vector-data-address-and-size v)
2094    (percentage-of-resident-pages address nbytes)))
2095)
2096
2097#+windows-target
2098(defun cygpath (winpath)
2099  "Try to use the Cygwin \"cygpath\" program to map a Windows-style
2100   pathname to a POSIX-stype Cygwin pathname."
2101  (let* ((posix-path winpath))
2102    (with-output-to-string (s)
2103      (multiple-value-bind (status exit-code)
2104          (external-process-status
2105           (run-program "cygpath" (list "-u" winpath) :output s))
2106        (when (and (eq status :exited)
2107                   (eql exit-code 0))
2108          (with-input-from-string (output (get-output-stream-string s))
2109            (setq posix-path (read-line output nil nil))))))
2110    posix-path))
2111
2112#-windows-target (defun cygpath (path) path)
2113     
2114
2115
2116
2117#+x86-target
2118(progn
2119(defloadvar *last-rdtsc-time* 0)
2120
2121(defstatic *rdtsc-estimated-increment* 1 "Should be positive ...")
2122
2123(defun rdtsc-monotonic ()
2124  "Return monotonically increasing values, partly compensating for
2125   OSes that don't keep the TSCs of all processorsin synch."
2126  (loop
2127    (let* ((old *last-rdtsc-time*)
2128           (new (rdtsc)))
2129      (when (< new old)
2130        ;; We're running on a CPU whose TSC is behind the one
2131        ;; on the last CPU we were scheduled on.
2132        (setq new (+ old *rdtsc-estimated-increment*)))
2133      (when (%store-node-conditional target::symbol.vcell *last-rdtsc-time* old new)
2134        (return new)))))
2135
2136(defun estimate-rdtsc-skew (&optional (niter 1000000))
2137  (do* ((i 0 (1+ i))
2138        (last (rdtsc) next)
2139        (next (rdtsc) (rdtsc))
2140        (skew 1))
2141       ((>= i niter) (setq *rdtsc-estimated-increment* skew))
2142    (declare (fixnum last next skew))
2143    (when (> last next)
2144      (let* ((s (- last next)))
2145        (declare (fixnum s))
2146        (when (> s skew) (setq skew s))))))
2147)
2148
2149
Note: See TracBrowser for help on using the repository browser.