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

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

On Win32, use :stat.
No #_GetLocalProcessorInformation in win32 headers (it's a relatively
new function). Use GetProcessAffinityMask? to count CPUs in CPU-COUNT.

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