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

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

Conditionalize for windows, share pipe implementation.

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