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

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

Move WITH-FILENAME-CSTRS elsewhere.

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