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

Last change on this file since 9657 was 9657, checked in by andreas, 13 years ago

Implement substitute for missing mktemp, and thus input redirection for RUN-APPLICATION.
Make sure there's always a process status there, even when program launch fails.

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