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

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

FD-GET-FLAGS: just do ff-call, don't bother with syscall.

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