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

Last change on this file since 9277 was 9277, checked in by gb, 13 years ago

stat fails on windows when pathname has trailing (forward or backward)
slash, so strip it off.
Use USERPROFILE env var to find home directory on Windows.
MS C library wants extra underscore before "unlink".
EOF-TRANSIENT-P on Windows if a console device, to some approximation.

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