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

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

Define GETTIMEOFDAY, which calls lisp_gettimeofday() in the kernel.
(gettimeofday() is prototyped in the mingw headers on Windows but
only available as statically linked code). Change other uses of
#_gettimeofday to call the GETTIMEOFDAY function. Remove some
Windows-specific code that was avoiding use of #_gettimeofday.

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