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

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

Stub out (or sometimes, actually implement) a few more things on
Windows; now compile without warnings on Windows.

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