source: branches/win64/level-1/linux-files.lisp @ 10033

Last change on this file since 10033 was 10033, checked in by gb, 12 years ago

Real-er %REALPATH for Windows.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 73.4 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(eval-when (:compile-toplevel :execute)
20  #+linuxppc-target
21  (require "PPC-LINUX-SYSCALLS")
22  #+linuxx8664-target
23  (require "X8664-LINUX-SYSCALLS")
24  #+darwinppc-target
25  (require "DARWINPPC-SYSCALLS")
26  #+darwinx8664-target
27  (require "DARWINX8664-SYSCALLS")
28  #+(and freebsd-target x8664-target)
29  (require "X8664-FREEBSD-SYSCALLS")
30  #+(and windows-target x8664-target)
31  (require "X86-WIN64-SYSCALLS")
32  )
33
34
35(defconstant unix-to-universal-time 2208988800)
36
37#+windows-target
38(progn
39
40(defun strip-drive-for-now (string)
41  string
42  #+no
43  (or (and (> (length string) 2)
44           (eql (schar string 1) #\:)
45           (let* ((copy (subseq string 0)))
46             (setf (schar copy 0) (char-downcase (schar copy 0)))
47             (setf (schar copy  1) #\|)
48             copy))
49      string))
50           
51
52(defun nbackslash-to-forward-slash (namestring)
53  (dotimes (i (length namestring) namestring)
54    (when (eql (schar namestring i) #\\)
55      (setf (schar namestring i) #\/))))
56
57(defconstant univeral-time-start-in-windows-seconds 9435484800)
58
59(defun windows-filetime-to-universal-time (ft)
60  (let* ((100-ns (dpb (pref ft #>FILETIME.dwHighDateTime) (byte 32 32)
61                      (pref ft #>FILETIME.dwLowDateTime)))
62         (seconds-since-windows-epoch (floor 100-ns 10000000)))
63    (- seconds-since-windows-epoch univeral-time-start-in-windows-seconds)))
64)
65
66
67(defun get-foreign-namestring (pointer)
68  ;; On Darwin, foreign namestrings are encoded in UTF-8 and
69  ;; are canonically decomposed (NFD).  Use PRECOMPOSE-SIMPLE-STRING
70  ;; to ensure that the string is "precomposed" (NFC), like the
71  ;; rest of the world and most sane people would expect.
72  #+darwin-target
73  (precompose-simple-string (%get-utf-8-cstring pointer))
74  #+windows-target (strip-drive-for-now
75                    (nbackslash-to-forward-slash
76                     (%get-native-utf-16-cstring pointer)))
77  ;; On some other platforms, the namestring is assumed to
78  ;; be encoded according to the current locale's character
79  ;; encoding (though FreeBSD seems to be moving towards
80  ;; precomposed UTF-8.).
81  ;; In any case, the use of %GET-CSTRING here is wrong ...
82  #-(or darwin-target windows-target)
83  (%get-cstring pointer))
84
85(defun nanoseconds (n)
86  (unless (and (typep n 'fixnum)
87               (>= (the fixnum n) 0))
88    (check-type n (real 0 #xffffffff)))
89  (multiple-value-bind (q r)
90      (floor n)
91    (if (zerop r)
92      (setq r 0)
93      (setq r (floor (* r 1000000000))))
94    (values q r)))
95
96(defun milliseconds (n)
97  (unless (and (typep n 'fixnum)
98               (>= (the fixnum n) 0))
99    (check-type n (real 0 #xffffffff)))
100  (multiple-value-bind (q r)
101      (floor n)
102    (if (zerop r)
103      (setq r 0)
104      (setq r (floor (* r 1000))))
105    (values q r)))
106
107(defun microseconds (n)
108  (unless (and (typep n 'fixnum)
109               (>= (the fixnum n) 0))
110    (check-type n (real 0 #xffffffff)))
111  (multiple-value-bind (q r)
112      (floor n)
113    (if (zerop r)
114      (setq r 0)
115      (setq r (floor (* r 1000000))))
116    (values q r)))
117
118(defun semaphore-value (s)
119  (if (istruct-typep s 'semaphore)
120    (semaphore.value s)
121    (semaphore-value (require-type s 'semaphore))))
122
123(defun %wait-on-semaphore-ptr (s seconds milliseconds &optional flag)
124  (if flag
125    (if (istruct-typep flag 'semaphore-notification)
126      (setf (semaphore-notification.status flag) nil)
127      (report-bad-arg flag 'semaphore-notification)))
128  (without-interrupts
129   (let* ((status (ff-call
130                   (%kernel-import target::kernel-import-wait-on-semaphore)
131                   :address s
132                   :unsigned seconds
133                   :unsigned milliseconds
134                   :signed))
135          (result (zerop status)))     
136     (declare (fixnum status))
137     (when flag (setf (semaphore-notification.status flag) result))
138     (values result status))))
139
140(defun %process-wait-on-semaphore-ptr (s seconds milliseconds &optional
141                                         (whostate "semaphore wait") flag)
142  (or (%wait-on-semaphore-ptr s 0 0 flag)
143      (with-process-whostate  (whostate)
144        (loop
145          (when (%wait-on-semaphore-ptr s seconds milliseconds flag)
146            (return))))))
147
148 
149(defun wait-on-semaphore (s &optional flag (whostate "semaphore wait"))
150  "Wait until the given semaphore has a positive count which can be
151atomically decremented."
152  (%process-wait-on-semaphore-ptr (semaphore-value s) #xffffff 0 whostate flag)
153  t)
154
155
156(defun %timed-wait-on-semaphore-ptr (semptr duration notification)
157  (or (%wait-on-semaphore-ptr semptr 0 0 notification)
158      (with-process-whostate ("Semaphore timed wait")
159        (multiple-value-bind (secs millis) (milliseconds duration)
160          (let* ((now (get-internal-real-time))
161                 (stop (+ now
162                          (* secs 1000)
163                          millis)))
164            (loop
165              (multiple-value-bind (success err)
166                  (progn
167                    (%wait-on-semaphore-ptr semptr secs millis notification))
168                (when success
169                  (return t))
170                (when (or (not (eql err #$EINTR))
171                          (>= (setq now (get-internal-real-time)) stop))
172                  (return nil))
173                (unless (zerop duration)
174                  (let* ((diff (- stop now)))
175                    (multiple-value-bind (remaining-seconds remaining-millis)
176                        (floor diff 1000)
177                      (setq secs remaining-seconds
178                            millis remaining-millis)))))))))))
179
180(defun timed-wait-on-semaphore (s duration &optional notification)
181  "Wait until the given semaphore has a postive count which can be
182atomically decremented, or until a timeout expires."
183  (%timed-wait-on-semaphore-ptr (semaphore-value s) duration notification))
184
185
186(defun %signal-semaphore-ptr (p)
187  (ff-call
188   (%kernel-import target::kernel-import-signal-semaphore)
189   :address p
190   :signed-fullword))
191
192(defun signal-semaphore (s)
193  "Atomically increment the count of a given semaphore."
194  (%signal-semaphore-ptr (semaphore-value s)))
195
196(defun %os-getcwd (buf bufsize)
197  ;; Return N < 0, if error
198  ;;        N < bufsize: success, string is of length n
199  ;;        N > bufsize: buffer needs to be larger.
200  (let* ((p (#+windows-target #__wgetcwd #-windows-target #_getcwd buf bufsize)))
201    (declare (dynamic-extent p))
202    (if (%null-ptr-p p)
203      (let* ((err (%get-errno)))
204        (if (eql err (- #$ERANGE))
205          (+ bufsize bufsize)
206          err))
207      #+windows-target
208      (do* ((i 0 (+ i 2)))
209           ((= i bufsize) (+ bufsize))
210        (when (eql (%get-unsigned-word buf i) 0)
211          (return (ash i -1))))
212      #-windows-target
213      (dotimes (i bufsize (+ bufsize bufsize))
214        (when (eql 0 (%get-byte buf i))
215          (return i))))))
216   
217   
218(defun current-directory-name ()
219  "Look up the current working directory of the OpenMCL process; unless
220it has been changed, this is the directory OpenMCL was started in."
221  (flet ((try-getting-dirname (bufsize)
222           (%stack-block ((buf bufsize))
223             (let* ((len (%os-getcwd buf bufsize)))
224               (cond ((< len 0) (%errno-disp len bufsize))
225                     ((< len bufsize)
226                      #+windows-target
227                      (setf (%get-unsigned-word buf (+ len len)) 0)
228                      #-windows-target
229                      (setf (%get-unsigned-byte buf len) 0)
230                      (values (get-foreign-namestring buf) len))
231                     (t (values nil len)))))))
232    (do* ((string nil)
233          (len 64)
234          (bufsize len len))
235         ((multiple-value-setq (string len) (try-getting-dirname bufsize))
236          string))))
237
238
239(defun current-directory ()
240  (mac-default-directory))
241
242(defun (setf current-directory) (path)
243  (cwd path)
244  path)
245
246(defun cd (path)
247  (cwd path))
248
249(defmacro with-filename-cstrs (&rest rest)
250  `(#+darwin-target with-utf-8-cstrs
251    #+windows-target with-native-utf-16-cstrs
252    #-(or darwin-target windows-target) with-cstrs ,@rest))
253
254(defmacro int-errno-call (form)
255  (let* ((result (gensym)))
256   `(let* ((,result ,form))
257     (if (< ,result 0)
258       (%get-errno)
259       ,result))))
260
261(defun %chdir (dirname)
262  (with-filename-cstrs ((dirname dirname))
263    (int-errno-call (#+windows-target #__wchdir #-windows-target #_chdir dirname))))
264
265(defun %mkdir (name mode)
266  #+windows-target (declare (ignore mode))
267  (let* ((name name)
268         (len (length name)))
269    (when (and (> len 0) (eql (char name (1- len)) #\/))
270      (setq name (subseq name 0 (1- len))))
271    (with-filename-cstrs ((name name))
272      (int-errno-call (#+windows-target #__wmkdir #-windows-target #_mkdir  name #-windows-target mode)))))
273
274(defun %rmdir (name)
275  (let* ((name name)
276         (len (length name)))
277    (when (and (> len 0)
278               (eql (char name (1- len)) #\/))
279      (setq name (subseq name 0 (1- len))))
280    (with-filename-cstrs ((name name))
281      (int-errno-call (#+windows-target #__wrmdir #-windows-target #_rmdir  name)))))
282
283
284(defun getenv (key)
285  "Look up the value of the environment variable named by name, in the
286OS environment."
287  (with-cstrs ((key (string key)))
288    (let* ((env-ptr (%null-ptr)))
289      (declare (dynamic-extent env-ptr))
290      (%setf-macptr env-ptr (#_getenv key))
291      (unless (%null-ptr-p env-ptr)
292        (%get-cstring env-ptr))))
293  )
294
295(defun setenv (key value &optional (overwrite t))
296  "Set the value of the environment variable named by name, in the OS
297environment. If there is no such environment variable, create it."
298  #+windows-target (declare (ignore overwrite))
299  #-windows-target
300  (with-cstrs ((ckey key)
301               (cvalue value))
302    (#_setenv ckey cvalue (if overwrite 1 0)))
303  #+windows-target
304  (with-cstrs ((pair (format nil "~a=~a" key value)))
305    (#__putenv pair))
306  )
307
308#-windows-target                        ; Windows "impersonation" crap ?
309(defun setuid (uid)
310  "Attempt to change the current user ID (both real and effective);
311fails unless the OpenMCL process has super-user privileges or the ID
312given is that of the current user."
313  (syscall syscalls::setuid uid))
314
315#-windows-target
316(defun setgid (uid)
317  "Attempt to change the current group ID (both real and effective);
318fails unless the OpenMCL process has super-user privileges or the ID
319given is that of a group to which the current user belongs."
320  (syscall syscalls::setgid uid))
321 
322
323;;; On Linux, "stat" & friends are implemented in terms of deeper,
324;;; darker things that need to know what version of the stat buffer
325;;; they're talking about.
326
327#-windows-target
328(defun %stat-values (result stat)
329  (if (eql 0 (the fixnum result)) 
330      (values
331       t
332       (pref stat :stat.st_mode)
333       (pref stat :stat.st_size)
334       #+linux-target
335       (pref stat :stat.st_mtim.tv_sec)
336       #-linux-target
337       (pref stat :stat.st_mtimespec.tv_sec)
338       (pref stat :stat.st_ino)
339       (pref stat :stat.st_uid)
340       (pref stat :stat.st_blksize)
341       #+linux-target
342       (round (pref stat :stat.st_mtim.tv_nsec) 1000)
343       #-linux-target
344       (round (pref stat :stat.st_mtimespec.tv_nsec) 1000)
345       (pref stat :stat.st_gid))
346      (values nil nil nil nil nil nil nil)))
347
348#+win64-target
349(defun %stat-values (result stat)
350  (if (eql 0 (the fixnum result)) 
351      (values
352       t
353       (pref stat :_stat64.st_mode)
354       (pref stat :_stat64.st_size)
355       (pref stat :_stat64.st_mtime)
356       (pref stat :_stat64.st_ino)
357       (pref stat :_stat64.st_uid)
358       #$BUFSIZ
359       (pref stat :_stat64.st_mtime)     ; ???
360       (pref stat :_stat64.st_gid))
361      (values nil nil nil nil nil nil nil nil nil)))
362
363#+windows-target
364(defun windows-strip-trailing-slash (namestring)
365  (do* ((len (length namestring) (length namestring)))
366       ((<= len 3) namestring)
367    (let* ((p (1- len))
368           (ch (char namestring p)))
369      (unless (or (eql ch #\\)
370                  (eql ch #\/))
371        (return namestring))
372      (setq namestring (subseq namestring 0 p)))))
373
374
375(defun %%stat (name stat)
376  (with-filename-cstrs ((cname #+windows-target (windows-strip-trailing-slash name) #-windows-target name))
377    (%stat-values
378     #+linux-target
379     (#_ __xstat #$_STAT_VER_LINUX cname stat)
380     #-linux-target
381     (int-errno-call (#+windows-target #__wstat64 #-windows-target #_stat cname stat))
382     stat)))
383
384(defun %%fstat (fd stat)
385  (%stat-values
386   #+linux-target
387   (#_ __fxstat #$_STAT_VER_LINUX fd stat)
388   #-linux-target
389   (int-errno-call (#+windows-target #__fstat64 #-windows-target #_fstat fd stat))
390   stat))
391
392#-windows-target
393(defun %%lstat (name stat)
394  (with-filename-cstrs ((cname name))
395    (%stat-values
396     #+linux-target
397     (#_ __lxstat #$_STAT_VER_LINUX cname stat)
398     #-linux-target
399     (syscall syscalls::lstat cname stat)
400     stat)))
401
402
403;;; Returns: (values t mode size mtime inode uid blksize) on success,
404;;;          (values nil nil nil nil nil nil nil) otherwise
405;;; NAME should be a "native namestring", e.g,, have all lisp pathname
406;;; escaping removed.
407#-windows-target
408(defun %stat (name &optional link-p)
409  (rlet ((stat  :stat))
410    (if link-p
411      (%%lstat name stat)
412      (%%stat name stat))))
413
414#+windows-target
415(defun %stat (name &optional link-p)
416  (declare (ignore link-p))
417  (rlet ((stat  #+win64-target #>_stat64))
418    (%%stat name stat)))
419
420(defun %fstat (fd)
421  (rlet ((stat #+win64-target #>_stat64 #-win64-target :stat))
422    (%%fstat fd stat)))
423
424
425(defun %file-kind (mode)
426  (when mode
427    (let* ((kind (logand mode #$S_IFMT)))
428      (cond ((eql kind #$S_IFDIR) :directory)
429            ((eql kind #$S_IFREG) :file)
430            #-windows-target
431            ((eql kind #$S_IFLNK) :link)
432            ((eql kind #$S_IFIFO) :pipe)
433            #-windows-target
434            ((eql kind #$S_IFSOCK) :socket)
435            ((eql kind #$S_IFCHR) :character-special)
436            (t :special)))))
437
438(defun %unix-file-kind (path &optional check-for-link)
439  (%file-kind (nth-value 1 (%stat (native-translated-namestring path) check-for-link))))
440
441(defun %unix-fd-kind (fd)
442  (if (isatty fd)
443    :tty
444    (%file-kind (nth-value 1 (%fstat fd)))))
445
446#-windows-target
447(defun %uts-string (result idx buf)
448  (if (eql 0 result)
449    (%get-cstring (%inc-ptr buf (* #+linux-target #$_UTSNAME_LENGTH
450                                   #+darwin-target #$_SYS_NAMELEN
451                                   #+freebsd-target #$SYS_NMLN idx)))
452    "unknown"))
453
454#-windows-target
455(defun copy-file-attributes (source-path dest-path)
456  "Copy the mode, owner, group and modification time of source-path to dest-path.
457   Returns T if succeeded, NIL if some of the attributes couldn't be copied due to
458   permission problems.  Any other failures cause an error to be signalled"
459  (multiple-value-bind (win mode ignore mtime-sec ignore uid ignore mtime-usec gid)
460                       (%stat (native-translated-namestring source-path) t)
461    (declare (ignore ignore))
462    (unless win
463      (error "Cannot get attributes of ~s" source-path))
464    (with-filename-cstrs ((cnamestr (native-translated-namestring dest-path)))
465      (macrolet ((errchk (form)
466                   `(let ((err ,form))
467                      (unless (eql err 0)
468                        (setq win nil)
469                        (when (eql err -1)
470                          (setq err (- (%get-errno))))
471                        (unless (eql err #$EPERM) (%errno-disp err dest-path))))))
472        (errchk (#_chmod cnamestr mode))
473        (errchk (%stack-block ((times (record-length (:array (:struct :timeval) 2))))
474                  (setf (pref times :timeval.tv_sec) mtime-sec)
475                  (setf (pref times :timeval.tv_usec) mtime-usec)
476                  (%incf-ptr times (record-length :timeval))
477                  (setf (pref times :timeval.tv_sec) mtime-sec)
478                  (setf (pref times :timeval.tv_usec) mtime-usec)
479                  (%incf-ptr times (- (record-length :timeval)))
480                  (#_utimes cnamestr times)))
481        (errchk (#_chown cnamestr uid gid))))
482    win))
483
484#+linux-target
485(defun %uname (idx)
486  (%stack-block ((buf (* #$_UTSNAME_LENGTH 6))) 
487    (%uts-string (syscall syscalls::uname buf) idx buf)))
488
489#+darwin-target
490(defun %uname (idx)
491  (%stack-block ((buf (* #$_SYS_NAMELEN 5)))
492    (%uts-string (#_uname buf) idx buf)))
493
494#+freebsd-target
495(defun %uname (idx)
496  (%stack-block ((buf (* #$SYS_NMLN 5)))
497    (%uts-string (#___xuname #$SYS_NMLN buf) idx buf)))
498
499#-windows-target
500(defun fd-dup (fd)
501  (int-errno-call (#_dup fd)))
502
503#+windows-target
504(defun fd-dup (fd &key direction inheritable)
505  (rlet ((handle #>HANDLE))
506    (#_DuplicateHandle (#_GetCurrentProcess)
507                       (#__get_osfhandle fd)
508                       (#_GetCurrentProcess) 
509                       handle
510                       0
511                       (if inheritable #$TRUE #$FALSE)
512                       #$DUPLICATE_SAME_ACCESS)
513    (#__open_osfhandle (pref handle #>HANDLE) (case direction
514                                                (:input #$O_RDONLY)
515                                                (:output #$O_WRONLY)
516                                                (t #$O_RDWR)))))
517                       
518
519(defun fd-fsync (fd)
520  #+windows-target (progn fd 0)
521  #-windows-target
522  (int-errno-call (#_fsync fd)))
523
524#-windows-target
525(progn
526(defun fd-get-flags (fd)
527  (syscall syscalls::fcntl fd #$F_GETFL))
528
529(defun fd-set-flags (fd new)
530  (syscall syscalls::fcntl fd #$F_SETFL new))
531
532(defun fd-set-flag (fd mask)
533  (let* ((old (fd-get-flags fd)))
534    (if (< old 0)
535      old
536      (fd-set-flags fd (logior old mask)))))
537
538(defun fd-clear-flag (fd mask)
539  (let* ((old (fd-get-flags fd)))
540    (if (< old 0) 
541      old
542      (fd-set-flags fd (logandc2 old mask)))))
543)
544
545;;; Assume that any quoting's been removed already.
546(defun tilde-expand (namestring)
547  (let* ((len (length namestring)))
548    (if (or (zerop len)
549            (not (eql (schar namestring 0) #\~)))
550      namestring
551      (if (or (= len 1)
552              (eql (schar namestring 1) #\/))
553        (concatenate 'string (get-user-home-dir (getuid)) (if (= len 1) "/" (subseq namestring 1)))
554        (let* ((slash-pos (position #\/ namestring))
555               (user-name (subseq namestring 1 slash-pos))
556               (uid (or (get-uid-from-name user-name)
557                        (error "Unknown user ~s in namestring ~s" user-name namestring))))
558          (concatenate 'string (get-user-home-dir uid) (if slash-pos (subseq namestring slash-pos) "/")))))))
559
560
561#+windows-target
562(defun %windows-realpath (namestring)
563  (with-filename-cstrs ((path namestring))
564    (do* ((bufsize 256))
565         ()
566      (%stack-block ((buf bufsize))
567        (let* ((nchars (#_GetFullPathNameW path (ash bufsize -1) buf +null-ptr+)))
568          (if (eql 0 nchars)
569            (return nil)
570            (let* ((max (+ nchars nchars 2)))
571              (if (> max bufsize)
572                (setq bufsize max)
573                (let* ((real (get-foreign-namestring buf)))
574                  (return (and (%stat real) real)))))))))))
575
576   
577;;; This doesn't seem to exist on VxWorks.  It's a POSIX
578;;; function AFAIK, so the source should be somewhere ...
579
580(defun %realpath (namestring)
581  ;; It's not at all right to just return the namestring here.
582  (when (zerop (length namestring))
583    (setq namestring (current-directory-name)))
584  #+windows-target (%windows-realpath namestring)
585  #-windows-target
586  (%stack-block ((resultbuf #$PATH_MAX))
587    (with-filename-cstrs ((name namestring #|(tilde-expand namestring)|#))
588      (let* ((result (#_realpath name resultbuf)))
589        (declare (dynamic-extent result))
590        (unless (%null-ptr-p result)
591          (get-foreign-namestring result))))))
592
593;;; Return fully resolved pathname & file kind, or (values nil nil)
594
595(defun %probe-file-x (namestring)
596  (let* ((realpath (%realpath namestring))
597         (kind (if realpath (%unix-file-kind realpath))))
598    (if kind
599      (values realpath kind)
600      (values nil nil))))
601
602(defun timeval->milliseconds (tv)
603    (+ (* 1000 (pref tv :timeval.tv_sec)) (round (pref tv :timeval.tv_usec) 1000)))
604
605(defun timeval->microseconds (tv)
606    (+ (* 1000000 (pref tv :timeval.tv_sec)) (pref tv :timeval.tv_usec)))
607
608(defun %add-timevals (result a b)
609  (let* ((seconds (+ (pref a :timeval.tv_sec) (pref b :timeval.tv_sec)))
610         (micros (+ (pref a :timeval.tv_usec) (pref b :timeval.tv_usec))))
611    (if (>= micros 1000000)
612      (setq seconds (1+ seconds) micros (- micros 1000000)))
613    (setf (pref result :timeval.tv_sec) seconds
614          (pref result :timeval.tv_usec) micros)
615    result))
616
617(defun %sub-timevals (result a b)
618  (let* ((seconds (- (pref a :timeval.tv_sec) (pref b :timeval.tv_sec)))
619         (micros (- (pref a :timeval.tv_usec) (pref b :timeval.tv_usec))))
620    (if (< micros 0)
621      (setq seconds (1- seconds) micros (+ micros 1000000)))
622    (setf (pref result :timeval.tv_sec) seconds
623          (pref result :timeval.tv_usec) micros)
624    result))
625
626;;; Return T iff the time denoted by the timeval a is not later than the
627;;; time denoted by the timeval b.
628(defun %timeval<= (a b)
629  (let* ((asec (pref a :timeval.tv_sec))
630         (bsec (pref b :timeval.tv_sec)))
631    (or (< asec bsec)
632        (and (= asec bsec)
633             (< (pref a :timeval.tv_usec)
634                (pref b :timeval.tv_usec))))))
635
636
637#-windows-target
638(defun %%rusage (usage &optional (who #$RUSAGE_SELF))
639  (syscall syscalls::getrusage who usage))
640
641
642
643(defun %file-write-date (namestring)
644  (let* ((date (nth-value 3 (%stat namestring))))
645    (if date
646      (+ date unix-to-universal-time))))
647
648#-windows-target
649(defun %file-author (namestring)
650  (let* ((uid (nth-value 5 (%stat namestring))))
651    (if uid
652      (with-macptrs ((pw (#_getpwuid uid)))
653        (unless (%null-ptr-p pw)
654          (without-interrupts
655           (%get-cstring (pref pw :passwd.pw_name))))))))
656
657#-windows-target
658(defun %utimes (namestring)
659  (with-filename-cstrs ((cnamestring namestring))
660    (let* ((err (#_utimes cnamestring (%null-ptr))))
661      (declare (fixnum err))
662      (or (eql err 0)
663          (%errno-disp err namestring)))))
664         
665
666#-windows-target
667(defun get-uid-from-name (name)
668  (with-cstrs ((name name))
669    (let* ((pwent (#_getpwnam name)))
670      (unless (%null-ptr-p pwent)
671        (pref pwent :passwd.pw_uid)))))
672
673
674(defun isatty (fd)
675  #+windows-target (declare (ignore fd))
676  #+windows-target nil
677  #-windows-target
678  (= 1 (#_isatty fd)))
679
680(defun %open-dir (namestring)
681  (with-filename-cstrs ((name namestring))
682    (let* ((DIR #+windows-target (syscall syscalls::opendir name)
683                #-windows-target (#_opendir name)))
684      (unless (%null-ptr-p DIR)
685        DIR))))
686
687(defun close-dir (dir)
688  #+windows-target (syscall syscalls::closedir DIR)
689  #-windows-target (#_closedir DIR))
690
691#-windows-target                        ;want a reentrant version, anyhow
692(defun %read-dir (dir)
693  (let* ((res (#_readdir dir)))
694    (unless (%null-ptr-p res)
695      (get-foreign-namestring (pref res :dirent.d_name)))))
696
697#+windows-target
698(defun %read-dir (dir)
699  (let* ((res (syscall syscalls::readdir dir)))
700    (unless (%null-ptr-p res)
701      (get-foreign-namestring (pref res :_wdirent.d_name)))))
702
703#-windows-target
704(defun tcgetpgrp (fd)
705  (#_tcgetpgrp fd))
706
707(defun getpid ()
708  "Return the ID of the OpenMCL OS process."
709  #-windows-target
710  (int-errno-call (#_getpid))
711  #+windows-target (#_GetCurrentProcessId))
712
713
714(defun getuid ()
715  "Return the (real) user ID of the current user."
716  #+windows-target 0
717  #-windows-target (int-errno-call (#_getuid)))
718
719(defun get-user-home-dir (userid)
720  "Look up and return the defined home directory of the user identified
721by uid. This value comes from the OS user database, not from the $HOME
722environment variable. Returns NIL if there is no user with the ID uid."
723  #+windows-target
724  (declare (ignore userid))
725  (with-native-utf-16-cstrs ((key "USERPROFILE"))
726    (let* ((p (#__wgetenv key)))
727      (unless (%null-ptr-p p)
728        (get-foreign-namestring p))))
729  #-windows-target
730  (rlet ((pwd :passwd)
731         (result :address))
732    (do* ((buflen 512 (* 2 buflen)))
733         ()
734      (%stack-block ((buf buflen))
735        (let* ((err (#_getpwuid_r userid pwd buf buflen result)))
736          (if (eql 0 err)
737            (return (get-foreign-namestring (pref pwd :passwd.pw_dir)))
738            (unless (eql err #$ERANGE)
739              (return nil))))))))
740
741(defun %delete-file (name)
742  (with-cstrs ((n name))
743    (int-errno-call (#+windows-target #__unlink #-windows-target #_unlink n))))
744
745(defun os-command (string)
746  "Invoke the Posix function system(), which invokes the user's default
747system shell (such as sh or tcsh) as a new process, and has that shell
748execute command-line.
749
750If the shell was able to find the command specified in command-line, then
751exit-code is the exit code of that command. If not, it is the exit code
752of the shell itself."
753  (with-cstrs ((s string))
754    (#_system s)))
755
756(defun %strerror (errno)
757  (declare (fixnum errno))
758  (if (< errno 0)
759    (setq errno (- errno)))
760  (with-macptrs (p)
761    (%setf-macptr p (#_strerror errno))
762    (if (%null-ptr-p p)
763      (format nil "OS Error %d" errno)
764      (%get-cstring p))))
765
766#+windows-target
767(defun %windows-error-string (error-number) 
768  (rlet ((pbuffer :address +null-ptr+))
769    (if (eql 0
770             (#_FormatMessageW (logior #$FORMAT_MESSAGE_ALLOCATE_BUFFER
771                                       #$FORMAT_MESSAGE_FROM_SYSTEM
772                                       #$FORMAT_MESSAGE_IGNORE_INSERTS
773                                       #$FORMAT_MESSAGE_MAX_WIDTH_MASK)
774                               +null-ptr+
775                               (abs error-number)
776                               0                 ; default langid, more-or-less
777                               pbuffer
778                               0
779                               +null-ptr+))
780      (format nil "Windows error ~d" (abs error-number))
781      (let* ((p (%get-ptr pbuffer))
782             (q (%get-native-utf-16-cstring p)))
783        (#_LocalFree p)
784        q))))
785       
786                     
787
788;;; Kind of has something to do with files, and doesn't work in level-0.
789#+(or linux-target freebsd-target)
790(defun close-shared-library (lib &key (completely t))
791  "If completely is T, set the reference count of library to 0. Otherwise,
792decrements it by 1. In either case, if the reference count becomes 0,
793close-shared-library frees all memory resources consumed library and causes
794any EXTERNAL-ENTRY-POINTs known to be defined by it to become unresolved."
795  (let* ((lib (if (typep lib 'string)
796                (or (shared-library-with-name lib)
797                    (error "Shared library ~s not found." lib))
798                (require-type lib 'shlib)))
799         (handle (shlib.handle lib)))
800      (when handle
801        (let* ((found nil)
802               (base (shlib.base lib)))
803          (do* ()
804               ((progn           
805                  (#_dlclose handle)
806                  (or (not (setq found (shlib-containing-address base)))
807                      (not completely)))))
808          (when (not found)
809            (setf (shlib.pathname lib) nil
810              (shlib.base lib) nil
811              (shlib.handle lib) nil
812              (shlib.map lib) nil)
813            (unload-foreign-variables lib)
814            (unload-library-entrypoints lib))))))
815
816#+darwin-target
817;; completely specifies whether to remove it totally from our list
818(defun close-shared-library (lib &key (completely nil))
819  "If completely is T, set the reference count of library to 0. Otherwise,
820decrements it by 1. In either case, if the reference count becomes 0,
821close-shared-library frees all memory resources consumed library and causes
822any EXTERNAL-ENTRY-POINTs known to be defined by it to become unresolved."
823  (let* ((lib (if (typep lib 'string)
824                  (or (shared-library-with-name lib)
825                      (error "Shared library ~s not found." lib))
826                (require-type lib 'shlib))))
827    ;; no possible danger closing libsystem since dylibs can't be closed
828    (cond
829     ((or (not (shlib.map lib)) (not (shlib.base lib)))
830      (error "Shared library ~s uninitialized." (shlib.soname lib)))
831     ((and (not (%null-ptr-p (shlib.map lib)))
832           (%null-ptr-p (shlib.base lib)))
833      (warn "Dynamic libraries cannot be closed on Darwin."))
834     ((and (%null-ptr-p (shlib.map lib))
835           (not (%null-ptr-p (shlib.base lib))))
836      ;; we have a bundle type library not sure what to do with the
837      ;; completely flag when we open the same bundle more than once,
838      ;; Darwin gives back a new module address, so we have multiple
839      ;; entries on *shared-libraries* the best we can do is unlink
840      ;; the module asked for (or our best guess based on name) and
841      ;; invalidate any entries which refer to this container
842      (if (= 0 (#_NSUnLinkModule (shlib.base lib) #$NSUNLINKMODULE_OPTION_NONE))
843          (error "Unable to close shared library, NSUnlinkModule failed.")
844        (progn
845          (setf (shlib.map lib) nil
846                (shlib.base lib) nil)
847          (unload-library-entrypoints lib)
848          (when completely
849            (setq *shared-libraries* (delete lib *shared-libraries*)))))))))
850
851
852
853;;; Foreign (unix) processes.
854
855(defun call-with-string-vector (function strings)
856  (let ((bufsize (reduce #'+ strings
857                         :key #'(lambda (s) (1+ (length (string s))))))
858        (argvsize (ash (1+ (length strings)) target::word-shift))
859        (bufpos 0)
860        (argvpos 0))
861    (%stack-block ((buf bufsize) (argv argvsize))
862      (flet ((init (s)
863             (multiple-value-bind (sstr start end) (get-sstring s)
864               (declare (fixnum start end))
865               (let ((len (- end start)))
866                 (declare (fixnum len))
867                 (do* ((i 0 (1+ i))
868                       (start start (1+ start))
869                       (bufpos bufpos (1+ bufpos)))
870                      ((= i len))
871                   (setf (%get-unsigned-byte buf bufpos)
872                         (logand #xff (%scharcode sstr start))))
873                 (setf (%get-byte buf (%i+ bufpos len)) 0)
874                 (setf (%get-ptr argv argvpos) (%inc-ptr buf bufpos))
875                 (setq bufpos (%i+ bufpos len 1))
876                 (setq argvpos (%i+ argvpos target::node-size))))))
877        (declare (dynamic-extent #'init))
878        (map nil #'init strings))
879      (setf (%get-ptr argv argvpos) (%null-ptr))
880      (funcall function argv))))
881
882(defmacro with-string-vector ((var &rest strings) &body body)
883  `(call-with-string-vector #'(lambda (,var) ,@body) ,@strings))
884
885(defloadvar *max-os-open-files* #-windows-target (#_getdtablesize) #+windows-target 32)
886
887#-windows-target
888(progn
889(defun %execvp (argv)
890  (#_execvp (%get-ptr argv) argv)
891  (#_exit #$EX_OSERR))
892
893(defun exec-with-io-redirection (new-in new-out new-err argv)
894  (#_setpgid 0 0)
895  (if new-in (#_dup2 new-in 0))
896  (if new-out (#_dup2 new-out 1))
897  (if new-err (#_dup2 new-err 2))
898  (do* ((fd 3 (1+ fd)))
899       ((= fd *max-os-open-files*) (%execvp argv))
900    (declare (fixnum fd))
901    (#_close fd)))
902
903
904
905
906
907;;; I believe that the Darwin/FreeBSD syscall infterface is rather ... odd.
908;;; Use libc's interface.
909(defun pipe ()
910  ;;  (rlet ((filedes (:array :int 2)))
911  (%stack-block ((filedes 8))
912    (let* ((status (#_pipe filedes))
913           (errno (if (eql status 0) 0 (%get-errno))))
914      (unless (zerop status)
915        (when (or (eql errno (- #$EMFILE))
916                  (eql errno (- #$ENFILE)))
917          (gc)
918          (drain-termination-queue)
919          (setq status (#_pipe filedes)
920                errno (if (zerop status) 0 (%get-errno)))))
921      (if (zerop status)
922        (values (paref filedes (:array :int)  0) (paref filedes (:array :int)  1))
923        (%errno-disp errno)))))
924
925
926
927(defstruct external-process
928  pid
929  %status
930  %exit-code
931  pty
932  input
933  output
934  error
935  status-hook
936  plist
937  token
938  core
939  args
940  (signal (make-semaphore))
941  (completed (make-semaphore))
942  watched-fd
943  watched-stream
944  )
945
946(defmethod print-object ((p external-process) stream)
947  (print-unreadable-object (p stream :type t :identity t)
948    (let* ((status (external-process-%status p)))
949      (let* ((*print-length* 3))
950        (format stream "~a" (external-process-args p)))
951      (format stream "[~d] (~a" (external-process-pid p) status)
952      (unless (eq status :running)
953        (format stream " : ~d" (external-process-%exit-code p)))
954      (format stream ")"))))
955
956(defun get-descriptor-for (object proc close-in-parent close-on-error
957                                  &rest keys &key direction (element-type 'character)
958                                  &allow-other-keys)
959  (etypecase object
960    ((eql t)
961     (values nil nil close-in-parent close-on-error))
962    (null
963     (let* ((null-device #+windows-target "nul" #-windows-target "/dev/null")
964            (fd (fd-open null-device (case direction
965                                       (:input #$O_RDONLY)
966                                       (:output #$O_WRONLY)
967                                       (t #$O_RDWR)))))
968       (if (< fd 0)
969         (signal-file-error fd null-device))
970       (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
971    ((eql :stream)
972     (multiple-value-bind (read-pipe write-pipe) (pipe)
973       (case direction
974         (:input
975          (values read-pipe
976                  (make-fd-stream write-pipe
977                                  :direction :output
978                                  :element-type element-type
979                                  :interactive nil
980                                  :basic t
981                                  :auto-close t)
982                  (cons read-pipe close-in-parent)
983                  (cons write-pipe close-on-error)))
984         (:output
985          (values write-pipe
986                  (make-fd-stream read-pipe
987                                  :direction :input
988                                  :element-type element-type
989                                  :interactive nil
990                                  :basic t
991                                  :auto-close t)
992                  (cons write-pipe close-in-parent)
993                  (cons read-pipe close-on-error)))
994         (t
995          (fd-close read-pipe)
996          (fd-close write-pipe)
997          (report-bad-arg direction '(member :input :output))))))
998    ((or pathname string)
999     (with-open-stream (file (apply #'open object keys))
1000       (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)))))
1001         (values fd
1002                 nil
1003                 (cons fd close-in-parent)
1004                 (cons fd close-on-error)))))
1005    (fd-stream
1006     (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
1007       (values fd
1008               nil
1009               (cons fd close-in-parent)
1010               (cons fd close-on-error))))
1011    (stream
1012     (ecase direction
1013       (:input
1014        (with-cstrs ((template "lisp-tempXXXXXX"))
1015          (let* ((fd (#_mkstemp template)))
1016            (if (< fd 0)
1017              (%errno-disp fd))
1018            (#_unlink template)
1019            (loop
1020              (multiple-value-bind (line no-newline)
1021                  (read-line object nil nil)
1022                (unless line
1023                  (return))
1024                (let* ((len (length line)))
1025                  (%stack-block ((buf (1+ len)))
1026                    (%cstr-pointer line buf)
1027                    (fd-write fd buf len)
1028                    (if no-newline
1029                      (return))
1030                    (setf (%get-byte buf) (char-code #\newline))
1031                    (fd-write fd buf 1)))))
1032            (fd-lseek fd 0 #$SEEK_SET)
1033            (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))))
1034       (:output
1035        (multiple-value-bind (read-pipe write-pipe) (pipe)
1036          (setf (external-process-watched-fd proc) read-pipe
1037                (external-process-watched-stream proc) object)
1038          (incf (car (external-process-token proc)))
1039          (values write-pipe
1040                  nil
1041                  (cons write-pipe close-in-parent)
1042                  (cons read-pipe close-on-error))))))))
1043
1044(let* ((external-processes ())
1045       (external-processes-lock (make-lock)))
1046  (defun add-external-process (p)
1047    (with-lock-grabbed (external-processes-lock)
1048      (push p external-processes)))
1049  (defun remove-external-process (p)
1050    (with-lock-grabbed (external-processes-lock)
1051      (setq external-processes (delete p external-processes))))
1052  ;; Likewise
1053  (defun external-processes ()
1054    (with-lock-grabbed (external-processes-lock)
1055      (copy-list external-processes)))
1056  )
1057
1058
1059(defmacro wtermsig (status)
1060  `(ldb (byte 7 0) ,status))
1061
1062(defmacro wexitstatus (status)
1063  `(ldb (byte 8 8) (the fixnum ,status)))
1064
1065(defmacro wstopsig (status)
1066  `(wexitstatus ,status))
1067
1068(defmacro wifexited (status)
1069  `(eql (wtermsig ,status) 0))
1070
1071(defmacro wifstopped (status)
1072  `(eql #x7f (ldb (byte 7 0) (the fixnum ,status))))
1073
1074(defun monitor-external-process (p)
1075  (let* ((in-fd (external-process-watched-fd p))
1076         (out-stream (external-process-watched-stream p))
1077         (token (external-process-token p))
1078         (terminated))
1079    (loop
1080      (when (and terminated (null in-fd))
1081        (signal-semaphore (external-process-completed p))
1082        (return))
1083      (when in-fd
1084        (when (fd-input-available-p in-fd 1000)
1085          (%stack-block ((buf 1024))
1086            (let* ((n (fd-read in-fd buf 1024)))
1087              (declare (fixnum n))
1088              (if (<= n 0)
1089                (progn
1090                  (without-interrupts
1091                   (decf (car token))
1092                   (fd-close in-fd)
1093                   (setq in-fd nil)))
1094                (let* ((string (make-string 1024)))
1095                  (declare (dynamic-extent string))
1096                  (%str-from-ptr buf n string)
1097                  (write-sequence string out-stream :end n)))))))
1098      (let* ((statusflags (check-pid (external-process-pid p)
1099                                     (logior
1100                                      (if in-fd #$WNOHANG 0)
1101                                      #$WUNTRACED)))
1102             (oldstatus (external-process-%status p)))
1103        (cond ((null statusflags)
1104               (remove-external-process p)
1105               (setq terminated t))
1106              ((eq statusflags t))      ; Running.
1107              (t
1108               (multiple-value-bind (status code core)
1109                   (cond ((wifstopped statusflags)
1110                          (values :stopped (wstopsig statusflags)))
1111                         ((wifexited statusflags)
1112                          (values :exited (wexitstatus statusflags)))
1113                         (t
1114                          (let* ((signal (wtermsig statusflags)))
1115                            (declare (fixnum signal))
1116                            (values
1117                             (if (or (= signal #$SIGSTOP)
1118                                     (= signal #$SIGTSTP)
1119                                     (= signal #$SIGTTIN)
1120                                     (= signal #$SIGTTOU))
1121                               :stopped
1122                               :signaled)
1123                             signal
1124                             (logtest #$WCOREFLAG statusflags)))))
1125                 (setf (external-process-%status p) status
1126                       (external-process-%exit-code p) code
1127                       (external-process-core p) core)
1128                 (let* ((status-hook (external-process-status-hook p)))
1129                   (when (and status-hook (not (eq oldstatus status)))
1130                     (funcall status-hook p)))
1131                 (when (or (eq status :exited)
1132                           (eq status :signaled))
1133                   (remove-external-process p)
1134                   (setq terminated t)))))))))
1135     
1136(defun run-external-process (proc in-fd out-fd error-fd &optional env)
1137  ;; type-check the env variable
1138  (dolist (pair env)
1139    (destructuring-bind (var . val) pair
1140      (assert (typep var '(or string symbol character)))
1141      (assert (typep val 'string)))) 
1142  (call-with-string-vector
1143   #'(lambda (argv)
1144       (let* ((child-pid (#_fork)))
1145         (declare (fixnum child-pid))
1146         (cond ((zerop child-pid)
1147                ;; Running in the child; do an exec
1148                (dolist (pair env)
1149                  (setenv (string (car pair)) (cdr pair)))
1150                (without-interrupts
1151                 (exec-with-io-redirection
1152                  in-fd out-fd error-fd argv)))
1153               ((> child-pid 0)
1154                ;; Running in the parent: success
1155                (setf (external-process-pid proc) child-pid)
1156                (add-external-process proc)
1157                (signal-semaphore (external-process-signal proc))
1158                (monitor-external-process proc)))))
1159   (external-process-args proc)))
1160
1161               
1162(defun run-program (program args &key
1163                            (wait t) pty
1164                            input if-input-does-not-exist
1165                            output (if-output-exists :error)
1166                            (error :output) (if-error-exists :error)
1167                            status-hook (element-type 'character)
1168                            env)
1169  "Invoke an external program as an OS subprocess of lisp."
1170  (declare (ignore pty))
1171  (unless (every #'(lambda (a) (typep a 'simple-string)) args)
1172    (error "Program args must all be simple strings : ~s" args))
1173  (push (native-untranslated-namestring program) args)
1174  (let* ((token (list 0))
1175         (in-fd nil)
1176         (in-stream nil)
1177         (out-fd nil)
1178         (out-stream nil)
1179         (error-fd nil)
1180         (error-stream nil)
1181         (close-in-parent nil)
1182         (close-on-error nil)
1183         (proc
1184          (make-external-process
1185           :pid nil
1186           :args args
1187           :%status :running
1188           :input nil
1189           :output nil
1190           :error nil
1191           :token token
1192           :status-hook status-hook)))
1193    (unwind-protect
1194         (progn
1195           (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
1196             (get-descriptor-for input proc  nil nil :direction :input
1197                                 :if-does-not-exist if-input-does-not-exist
1198                                 :element-type element-type))
1199           (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
1200             (get-descriptor-for output proc close-in-parent close-on-error
1201                                 :direction :output
1202                                 :if-exists if-output-exists
1203                                 :element-type element-type))
1204           (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
1205             (if (eq error :output)
1206               (values out-fd out-stream close-in-parent close-on-error)
1207               (get-descriptor-for error proc close-in-parent close-on-error
1208                                   :direction :output
1209                                   :if-exists if-error-exists
1210                                   :element-type element-type)))
1211           (setf (external-process-input proc) in-stream
1212                 (external-process-output proc) out-stream
1213                 (external-process-error proc) error-stream)
1214           (process-run-function
1215            (format nil "Monitor thread for external process ~a" args)
1216                   
1217            #'run-external-process proc in-fd out-fd error-fd env)
1218           (wait-on-semaphore (external-process-signal proc))
1219           )
1220      (dolist (fd close-in-parent) (fd-close fd))
1221      (unless (external-process-pid proc)
1222        (dolist (fd close-on-error) (fd-close fd)))
1223      (when (and wait (external-process-pid proc))
1224        (with-interrupts-enabled
1225            (wait-on-semaphore (external-process-completed proc)))))
1226    (and (external-process-pid proc) proc)))
1227
1228
1229
1230
1231(defmacro wifsignaled (status)
1232  (let* ((statname (gensym)))
1233    `(let* ((,statname ,status))
1234      (and (not (wifstopped ,statname)) (not (wifexited ,statname))))))
1235
1236
1237(defun check-pid (pid &optional (flags (logior  #$WNOHANG #$WUNTRACED)))
1238  (declare (fixnum pid))
1239  (rlet ((status :signed))
1240    (let* ((retval (#_waitpid pid status flags)))
1241      (declare (fixnum retval))
1242      (if (= retval pid)
1243        (pref status :signed)
1244        (zerop retval)))))
1245
1246
1247
1248
1249
1250(defun external-process-wait (proc &optional check-stopped)
1251  (process-wait "external-process-wait"
1252                #'(lambda ()
1253                    (case (external-process-%status proc)
1254                      (:running)
1255                      (:stopped
1256                       (when check-stopped
1257                         t))
1258                      (t
1259                       (when (zerop (car (external-process-token proc)))
1260                         t))))))
1261
1262(defun external-process-status (proc)
1263  "Return information about whether an OS subprocess is running; or, if
1264not, why not; and what its result code was if it completed."
1265  (require-type proc 'external-process)
1266  (values (external-process-%status proc)
1267          (external-process-%exit-code proc)))
1268
1269(defun external-process-input-stream (proc)
1270  "Return the lisp stream which is used to write input to a given OS
1271subprocess, if it has one."
1272  (require-type proc 'external-process)
1273  (external-process-input proc))
1274
1275(defun external-process-output-stream (proc)
1276  "Return the lisp stream which is used to read output from a given OS
1277subprocess, if there is one."
1278  (require-type proc 'external-process)
1279  (external-process-output proc))
1280
1281(defun external-process-error-stream (proc)
1282  "Return the stream which is used to read error output from a given OS
1283subprocess, if it has one."
1284  (require-type proc 'external-process)
1285  (external-process-error proc))
1286
1287(defun external-process-id (proc)
1288  "Return the process id of an OS subprocess, a positive integer which
1289identifies it."
1290  (require-type proc 'external-process)
1291  (external-process-pid proc))
1292 
1293(defun signal-external-process (proc signal)
1294  "Send the specified signal to the specified external process.  (Typically,
1295it would only be useful to call this function if the EXTERNAL-PROCESS was
1296created with :WAIT NIL.) Return T if successful; signal an error otherwise."
1297  (require-type proc 'external-process)
1298  (let* ((pid (external-process-pid proc))
1299         (error (syscall syscalls::kill pid signal)))
1300    (or (eql error 0)
1301        (%errno-disp error))))
1302
1303) ; #-windows-target (progn
1304
1305#+windows-target
1306(progn
1307(defun temp-file-name (prefix)
1308  "Returns a unique name for a temporary file, residing in system temp
1309space, and prefixed with PREFIX."
1310  (rlet ((buffer (:array :wchar_t #.#$MAX_PATH)))
1311    (#_GetTempPathW #$MAX_PATH buffer)
1312    (with-filename-cstrs ((c-prefix prefix)) 
1313      (#_GetTempFileNameW buffer c-prefix 0 buffer)
1314      (%get-native-utf-16-cstring buffer))))
1315 
1316(defun get-descriptor-for (object proc close-in-parent close-on-error
1317                                  &rest keys &key direction (element-type 'character)
1318                                  &allow-other-keys)
1319  (etypecase object
1320    ((eql t)
1321     (values nil nil close-in-parent close-on-error))
1322    (null
1323     (let* ((null-device "nul")
1324            (fd (fd-open null-device (case direction
1325                                       (:input #$O_RDONLY)
1326                                       (:output #$O_WRONLY)
1327                                       (t #$O_RDWR)))))
1328       (if (< fd 0)
1329         (signal-file-error fd null-device))
1330       (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
1331    ((eql :stream)
1332     (multiple-value-bind (read-pipe write-pipe) (pipe)
1333       (case direction
1334         (:input
1335          (values read-pipe
1336                  (make-fd-stream (fd-uninheritable write-pipe :direction :output)
1337                                  :direction :output
1338                                  :element-type element-type
1339                                  :interactive nil
1340                                  :basic t
1341                                  :auto-close t)
1342                  (cons read-pipe close-in-parent)
1343                  (cons write-pipe close-on-error)))
1344         (:output
1345          (values write-pipe
1346                  (make-fd-stream (fd-uninheritable read-pipe :direction :input)
1347                                  :direction :input
1348                                  :element-type element-type
1349                                  :interactive nil
1350                                  :basic t
1351                                  :auto-close t)
1352                  (cons write-pipe close-in-parent)
1353                  (cons read-pipe close-on-error)))
1354         (t
1355          (fd-close read-pipe)
1356          (fd-close write-pipe)
1357          (report-bad-arg direction '(member :input :output))))))
1358    ((or pathname string)
1359     (with-open-stream (file (apply #'open object keys))
1360       (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)) :direction direction :inheritable t)))
1361         (values fd
1362                 nil
1363                 (cons fd close-in-parent)
1364                 (cons fd close-on-error)))))
1365    (fd-stream
1366     (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
1367       (values fd
1368               nil
1369               (cons fd close-in-parent)
1370               (cons fd close-on-error))))
1371    (stream
1372     (ecase direction
1373       (:input
1374        (let* ((tempname (temp-file-name "lisp-temp"))
1375               (fd (fd-open tempname #$O_RDWR)))
1376          (if (< fd 0)
1377            (%errno-disp fd))
1378          (loop
1379            (multiple-value-bind (line no-newline)
1380                (read-line object nil nil)
1381              (unless line
1382                (return))
1383              (let* ((len (length line)))
1384                (%stack-block ((buf (1+ len)))
1385                  (%cstr-pointer line buf)
1386                  (fd-write fd buf len)
1387                  (if no-newline
1388                    (return))
1389                  (setf (%get-byte buf) (char-code #\newline))
1390                  (fd-write fd buf 1)))))
1391          (fd-lseek fd 0 #$SEEK_SET)
1392          (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
1393       (:output
1394        (multiple-value-bind (read-pipe write-pipe) (pipe)
1395          (setf (external-process-watched-fd proc) read-pipe
1396                (external-process-watched-stream proc) object)
1397          (incf (car (external-process-token proc)))
1398          (values write-pipe
1399                  nil
1400                  (cons write-pipe close-in-parent)
1401                  (cons read-pipe close-on-error))))))))
1402
1403(defstruct external-process
1404  pid
1405  %status
1406  %exit-code
1407  pty
1408  input
1409  output
1410  error
1411  status-hook
1412  plist
1413  token
1414  core
1415  args
1416  (signal (make-semaphore))
1417  (completed (make-semaphore))
1418  watched-fd
1419  watched-stream
1420  )
1421
1422(defun external-process-status (proc)
1423  "Return information about whether an OS subprocess is running; or, if
1424not, why not; and what its result code was if it completed."
1425  (require-type proc 'external-process)
1426  (values (external-process-%status proc)
1427          (external-process-%exit-code proc)))
1428
1429
1430(defmethod print-object ((p external-process) stream)
1431  (print-unreadable-object (p stream :type t :identity t)
1432    (let* ((status (external-process-%status p)))
1433      (let* ((*print-length* 3))
1434        (format stream "~a" (external-process-args p)))
1435      (format stream "[~d] (~a" (external-process-pid p) status)
1436      (unless (eq status :running)
1437        (format stream " : ~d" (external-process-%exit-code p)))
1438      (format stream ")"))))
1439
1440(defun run-program (program args &key
1441                            (wait t) pty
1442                            input if-input-does-not-exist
1443                            output (if-output-exists :error)
1444                            (error :output) (if-error-exists :error)
1445                            status-hook (element-type 'character)
1446                            env)
1447  "Invoke an external program as an OS subprocess of lisp."
1448  (declare (ignore pty))
1449  (unless (every #'(lambda (a) (typep a 'simple-string)) args)
1450    (error "Program args must all be simple strings : ~s" args))
1451  (push program args)
1452  (let* ((token (list 0))
1453         (in-fd nil)
1454         (in-stream nil)
1455         (out-fd nil)
1456         (out-stream nil)
1457         (error-fd nil)
1458         (error-stream nil)
1459         (close-in-parent nil)
1460         (close-on-error nil)
1461         (proc
1462          (make-external-process
1463           :pid nil
1464           :args args
1465           :%status :running
1466           :input nil
1467           :output nil
1468           :error nil
1469           :token token
1470           :status-hook status-hook)))
1471    (unwind-protect
1472         (progn
1473           (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
1474             (get-descriptor-for input proc  nil nil :direction :input
1475                                 :if-does-not-exist if-input-does-not-exist
1476                                 :element-type element-type))
1477           (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
1478             (get-descriptor-for output proc close-in-parent close-on-error
1479                                 :direction :output
1480                                 :if-exists if-output-exists
1481                                 :element-type element-type))
1482           (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
1483             (if (eq error :output)
1484               (values out-fd out-stream close-in-parent close-on-error)
1485               (get-descriptor-for error proc close-in-parent close-on-error
1486                                   :direction :output
1487                                   :if-exists if-error-exists
1488                                   :element-type element-type)))
1489           (setf (external-process-input proc) in-stream
1490                 (external-process-output proc) out-stream
1491                 (external-process-error proc) error-stream)
1492           (process-run-function
1493            (format nil "Monitor thread for external process ~a" args)
1494                   
1495            #'run-external-process proc in-fd out-fd error-fd env)
1496           (wait-on-semaphore (external-process-signal proc))
1497           )
1498      (dolist (fd close-in-parent) (fd-close fd))
1499      (if (external-process-pid proc)
1500        (when (and wait (external-process-pid proc))
1501          (with-interrupts-enabled
1502              (wait-on-semaphore (external-process-completed proc))))
1503        (progn
1504          (dolist (fd close-on-error) (fd-close fd))
1505          (error "Process execution failed"))))
1506    proc))
1507
1508(let* ((external-processes ())
1509       (external-processes-lock (make-lock)))
1510  (defun add-external-process (p)
1511    (with-lock-grabbed (external-processes-lock)
1512      (push p external-processes)))
1513  (defun remove-external-process (p)
1514    (with-lock-grabbed (external-processes-lock)
1515      (setq external-processes (delete p external-processes))))
1516  ;; Likewise
1517  (defun external-processes ()
1518    (with-lock-grabbed (external-processes-lock)
1519      (copy-list external-processes)))
1520  )
1521
1522
1523(defun pipe ()
1524  (%stack-block ((filedes 8))
1525    (syscall syscalls::pipe filedes)
1526    (values (paref filedes (:array :int)  0) (paref filedes (:array :int)  1))))
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
1633(defstruct (shared-resource (:constructor make-shared-resource (name)))
1634  (name)
1635  (lock (make-lock))
1636  (primary-owner *current-process*)
1637  (primary-owner-notify (make-semaphore))
1638  (current-owner nil)
1639  (requestors (make-dll-header)))
1640
1641(defstruct (shared-resource-request
1642             (:constructor make-shared-resource-request (process))
1643             (:include dll-node))
1644  process
1645  (signal (make-semaphore)))
1646             
1647
1648;; Returns NIL if already owned by calling thread, T otherwise
1649(defun %acquire-shared-resource (resource  &optional verbose)
1650  (let* ((current *current-process*))
1651    (with-lock-grabbed ((shared-resource-lock resource))
1652      (let* ((secondary (shared-resource-current-owner resource)))
1653        (if (or (eq current secondary)
1654                (and (null secondary)
1655                     (eq current (shared-resource-primary-owner resource))))
1656          (return-from %acquire-shared-resource nil))))
1657    (let* ((request (make-shared-resource-request *current-process*)))
1658      (when verbose
1659        (format t "~%~%;;;~%;;; ~a requires access to ~a~%;;;~%~%"
1660                *current-process* (shared-resource-name resource)))
1661      (with-lock-grabbed ((shared-resource-lock resource))
1662        (append-dll-node request (shared-resource-requestors resource)))
1663      (wait-on-semaphore (shared-resource-request-signal request))
1664      (assert (eq current (shared-resource-current-owner resource)))
1665      (when verbose
1666        (format t "~%~%;;;~%;;; ~a is now owned by ~a~%;;;~%~%"
1667                (shared-resource-name resource) current))
1668      t)))
1669
1670;;; If we're the primary owner and there is no secondary owner, do nothing.
1671;;; If we're the secondary owner, cease being the secondary owner.
1672(defun %release-shared-resource (r)
1673  (let* ((not-any-owner ()))
1674    (with-lock-grabbed ((shared-resource-lock r))
1675      (let* ((current *current-process*)
1676             (primary (shared-resource-primary-owner r))
1677             (secondary (shared-resource-current-owner r)))
1678        (unless (setq not-any-owner
1679                      (not (or (eq current secondary)
1680                               (and (null secondary)
1681                                    (eq current primary)))))
1682          (when (eq current secondary)
1683            (setf (shared-resource-current-owner r) nil)
1684            (signal-semaphore (shared-resource-primary-owner-notify r))))))
1685    (when not-any-owner
1686      (signal-program-error "Process ~a does not own ~a" *current-process*
1687                            (shared-resource-name r)))))
1688
1689;;; The current thread should be the primary owner; there should be
1690;;; no secondary owner.  Wakeup the specified (or first) requesting
1691;;; process, then block on our semaphore
1692(defun %yield-shared-resource (r &optional to)
1693  (let* ((request nil))
1694    (with-lock-grabbed ((shared-resource-lock r))
1695      (let* ((current *current-process*)
1696             (primary (shared-resource-primary-owner r)))
1697        (when (and (eq current primary)
1698                   (null (shared-resource-current-owner r)))
1699          (setq request
1700                (let* ((header (shared-resource-requestors r)))
1701                  (if to 
1702                    (do-dll-nodes (node header)
1703                      (when (eq to (shared-resource-request-process node))
1704                        (return node)))
1705                    (let* ((first (dll-header-first header)))
1706                      (unless (eq first header)
1707                        first)))))
1708          (when request
1709            (remove-dll-node request)
1710            (setf (shared-resource-current-owner r)
1711                  (shared-resource-request-process request))
1712            (signal-semaphore (shared-resource-request-signal request))))))
1713    (when request
1714      (wait-on-semaphore (shared-resource-primary-owner-notify r))
1715      (format t "~%;;;~%;;;control of ~a restored to ~a~%;;;~&"
1716              (shared-resource-name r)
1717              *current-process*))))
1718
1719
1720     
1721
1722(defun %shared-resource-requestor-p (r proc)
1723  (with-lock-grabbed ((shared-resource-lock r))
1724    (do-dll-nodes (node (shared-resource-requestors r))
1725      (when (eq proc (shared-resource-request-process node))
1726        (return t)))))
1727
1728(defparameter *resident-editor-hook* nil
1729  "If non-NIL, should be a function that takes an optional argument
1730   (like ED) and invokes a \"resident\" editor.")
1731
1732(defun ed (&optional arg)
1733  (if *resident-editor-hook*
1734    (funcall *resident-editor-hook* arg)
1735    (error "This implementation doesn't provide a resident editor.")))
1736
1737(defun running-under-emacs-p ()
1738  (not (null (getenv "EMACS"))))
1739
1740(defloadvar *cpu-count* nil)
1741
1742(defun cpu-count ()
1743  (or *cpu-count*
1744      (setq *cpu-count*
1745            #+darwin-target
1746            (rlet ((info :host_basic_info)
1747                   (count :mach_msg_type_number_t #$HOST_BASIC_INFO_COUNT))
1748              (if (eql #$KERN_SUCCESS (#_host_info (#_mach_host_self)
1749                                                   #$HOST_BASIC_INFO
1750                                                   info
1751                                                   count))
1752                (pref info :host_basic_info.max_cpus)
1753                1))
1754            #+linux-target
1755            (or
1756             (let* ((n (#_sysconf #$_SC_NPROCESSORS_ONLN)))
1757               (declare (fixnum n))
1758               (if (> n 0) n))
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.