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

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

Don't use syscall interfaces (in the many places that we did).
(Remaining cases are actually windows-specific, where we use
"syscall" to reach code in the lisp kernel.)
Conditionalize for Windows in other ways, too.

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