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

Last change on this file since 10133 was 10133, checked in by rme, 11 years ago

Darwin/x8632 conditionalization.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 54.9 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)
349  (if (eql 0 result)
[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)
[1546]415  (syscall syscalls::fcntl fd #$F_GETFL))
[6]416
417(defun fd-set-flags (fd new)
[1546]418  (syscall syscalls::fcntl fd #$F_SETFL new))
[6]419
420(defun fd-set-flag (fd mask)
421  (let* ((old (fd-get-flags fd)))
422    (if (< old 0)
423      old
424      (fd-set-flags fd (logior old mask)))))
425
426(defun fd-clear-flag (fd mask)
427  (let* ((old (fd-get-flags fd)))
428    (if (< old 0) 
429      old
430      (fd-set-flags fd (logandc2 old mask)))))
431
[6634]432
433;;; Assume that any quoting's been removed already.
434(defun tilde-expand (namestring)
435  (let* ((len (length namestring)))
436    (if (or (zerop len)
437            (not (eql (schar namestring 0) #\~)))
438      namestring
439      (if (or (= len 1)
440              (eql (schar namestring 1) #\/))
441        (concatenate 'string (get-user-home-dir (getuid)) (if (= len 1) "/" (subseq namestring 1)))
442        (let* ((slash-pos (position #\/ namestring))
443               (user-name (subseq namestring 1 slash-pos))
444               (uid (or (get-uid-from-name user-name)
445                        (error "Unknown user ~s in namestring ~s" user-name namestring))))
446          (concatenate 'string (get-user-home-dir uid) (if slash-pos (subseq namestring slash-pos) "/")))))))
447
448                     
449   
[6]450;;; This doesn't seem to exist on VxWorks.  It's a POSIX
451;;; function AFAIK, so the source should be somewhere ...
452
453(defun %realpath (namestring)
[4525]454  (when (zerop (length namestring))
455    (setq namestring (current-directory-name)))
[3960]456  (%stack-block ((resultbuf #$PATH_MAX))
[8343]457    (with-filename-cstrs ((name namestring #|(tilde-expand namestring)|#))
[6]458      (let* ((result (#_realpath name resultbuf)))
459        (declare (dynamic-extent result))
460        (unless (%null-ptr-p result)
[7624]461          (get-foreign-namestring result))))))
[6]462
[3960]463;;; Return fully resolved pathname & file kind, or (values nil nil)
[6]464
465(defun %probe-file-x (namestring)
466  (let* ((realpath (%realpath namestring))
467         (kind (if realpath (%unix-file-kind realpath))))
468    (if kind
469      (values realpath kind)
470      (values nil nil))))
471
472(defun timeval->milliseconds (tv)
473    (+ (* 1000 (pref tv :timeval.tv_sec)) (round (pref tv :timeval.tv_usec) 1000)))
474
[7951]475(defun timeval->microseconds (tv)
476    (+ (* 1000000 (pref tv :timeval.tv_sec)) (pref tv :timeval.tv_usec)))
[6]477
478(defun %add-timevals (result a b)
479  (let* ((seconds (+ (pref a :timeval.tv_sec) (pref b :timeval.tv_sec)))
480         (micros (+ (pref a :timeval.tv_usec) (pref b :timeval.tv_usec))))
481    (if (>= micros 1000000)
482      (setq seconds (1+ seconds) micros (- micros 1000000)))
483    (setf (pref result :timeval.tv_sec) seconds
484          (pref result :timeval.tv_usec) micros)
485    result))
486
[1825]487(defun %sub-timevals (result a b)
488  (let* ((seconds (- (pref a :timeval.tv_sec) (pref b :timeval.tv_sec)))
489         (micros (- (pref a :timeval.tv_usec) (pref b :timeval.tv_usec))))
490    (if (< micros 0)
491      (setq seconds (1- seconds) micros (+ micros 1000000)))
492    (setf (pref result :timeval.tv_sec) seconds
493          (pref result :timeval.tv_usec) micros)
494    result))
[6]495
[8267]496;;; Return T iff the time denoted by the timeval a is not later than the
497;;; time denoted by the timeval b.
498(defun %timeval<= (a b)
499  (let* ((asec (pref a :timeval.tv_sec))
500         (bsec (pref b :timeval.tv_sec)))
501    (or (< asec bsec)
502        (and (= asec bsec)
503             (< (pref a :timeval.tv_usec)
504                (pref b :timeval.tv_usec))))))
[6]505
[8267]506
[6]507(defun %%rusage (usage &optional (who #$RUSAGE_SELF))
[10053]508  #-solaris-target
509  (syscall syscalls::getrusage who usage)
510  #+solaris-target
511  (syscall syscalls::rusagesys #$_RUSAGESYS_GETRUSAGE who usage)
512  )
[6]513
[90]514
[6]515
516(defconstant unix-to-universal-time 2208988800)
517
518(defun %file-write-date (namestring)
519  (let* ((date (nth-value 3 (%stat namestring))))
520    (if date
521      (+ date unix-to-universal-time))))
522
523(defun %file-author (namestring)
524  (let* ((uid (nth-value 5 (%stat namestring))))
525    (if uid
526      (with-macptrs ((pw (#_getpwuid uid)))
527        (unless (%null-ptr-p pw)
528          (without-interrupts
529           (%get-cstring (pref pw :passwd.pw_name))))))))
530
531(defun %utimes (namestring)
[8343]532  (with-filename-cstrs ((cnamestring namestring))
[6]533    (let* ((err (#_utimes cnamestring (%null-ptr))))
534      (declare (fixnum err))
535      (or (eql err 0)
536          (%errno-disp err namestring)))))
537         
538
[6634]539(defun get-uid-from-name (name)
540  (with-cstrs ((name name))
541    (let* ((pwent (#_getpwnam name)))
542      (unless (%null-ptr-p pwent)
543        (pref pwent :passwd.pw_uid)))))
544
545   
[6]546(defun isatty (fd)
547  (= 1 (#_isatty fd)))
548
549(defun %open-dir (namestring)
[8343]550  (with-filename-cstrs ((name namestring))
[6]551    (let* ((DIR (#_opendir name)))
552      (unless (%null-ptr-p DIR)
553        DIR))))
554
555(defun close-dir (dir)
556  (#_closedir DIR))
557
558(defun %read-dir (dir)
[9212]559  (rlet ((entry #>dirent)
560         (presult :address +null-ptr+))
561    (let* ((err (#_readdir_r dir entry presult))
562           (result (%get-ptr presult)))
563      (declare (fixnum err) (dynamic-extent result))
564      (when (zerop err)
565        (unless (%null-ptr-p result)
566          (get-foreign-namestring (pref result #>dirent.d_name)))))))
[6]567
568(defun tcgetpgrp (fd)
569  (#_tcgetpgrp fd))
570
571(defun getpid ()
[2444]572  "Return the ID of the OpenMCL OS process."
[1546]573  (syscall syscalls::getpid))
[6]574
575(defun getuid ()
[2444]576  "Return the (real) user ID of the current user."
[1546]577  (syscall syscalls::getuid))
[6]578
579(defun get-user-home-dir (userid)
[2444]580  "Look up and return the defined home directory of the user identified
581by uid. This value comes from the OS user database, not from the $HOME
582environment variable. Returns NIL if there is no user with the ID uid."
[4828]583  (rlet ((pwd :passwd)
584         (result :address))
585    (do* ((buflen 512 (* 2 buflen)))
586         ()
587      (%stack-block ((buf buflen))
[10067]588        (let* ((err
589                #-solaris-target
590                 (#_getpwuid_r userid pwd buf buflen result)
591                 #+solaris-target
592                 (external-call "__posix_getpwuid_r"
593                                :uid_t userid
594                                :address pwd
595                                :address buf
596                                :int buflen
597                                :address result
598                                :int)))
[4828]599          (if (eql 0 err)
[7624]600            (return (get-foreign-namestring (pref pwd :passwd.pw_dir)))
[4828]601            (unless (eql err #$ERANGE)
602              (return nil))))))))
[6]603
604(defun %delete-file (name)
605  (with-cstrs ((n name))
[1546]606    (syscall syscalls::unlink n)))
[6]607
608(defun os-command (string)
[2444]609  "Invoke the Posix function system(), which invokes the user's default
610system shell (such as sh or tcsh) as a new process, and has that shell
611execute command-line.
612
613If the shell was able to find the command specified in command-line, then
614exit-code is the exit code of that command. If not, it is the exit code
615of the shell itself."
[6]616  (with-cstrs ((s string))
617    (#_system s)))
618
619(defun %strerror (errno)
620  (declare (fixnum errno))
621  (if (< errno 0)
622    (setq errno (- errno)))
623  (with-macptrs (p)
624    (%setf-macptr p (#_strerror errno))
625    (if (%null-ptr-p p)
626      (format nil "OS Error %d" errno)
627      (%get-cstring p))))
628
629;;; Kind of has something to do with files, and doesn't work in level-0.
[10053]630#+(or linux-target freebsd-target solaris-target)
[6]631(defun close-shared-library (lib &key (completely t))
[2442]632  "If completely is T, set the reference count of library to 0. Otherwise,
633decrements it by 1. In either case, if the reference count becomes 0,
634close-shared-library frees all memory resources consumed library and causes
635any EXTERNAL-ENTRY-POINTs known to be defined by it to become unresolved."
[6]636  (let* ((lib (if (typep lib 'string)
637                (or (shared-library-with-name lib)
638                    (error "Shared library ~s not found." lib))
639                (require-type lib 'shlib)))
[8587]640         (handle (shlib.handle lib)))
641      (when handle
[6]642        (let* ((found nil)
643               (base (shlib.base lib)))
644          (do* ()
645               ((progn           
[8587]646                  (#_dlclose handle)
[6]647                  (or (not (setq found (shlib-containing-address base)))
648                      (not completely)))))
649          (when (not found)
650            (setf (shlib.pathname lib) nil
651              (shlib.base lib) nil
[8587]652              (shlib.handle lib) nil
[6]653              (shlib.map lib) nil)
[812]654            (unload-foreign-variables lib)
[8587]655            (unload-library-entrypoints lib))))))
[6]656
[4994]657#+darwin-target
[6]658;; completely specifies whether to remove it totally from our list
659(defun close-shared-library (lib &key (completely nil))
[2442]660  "If completely is T, set the reference count of library to 0. Otherwise,
661decrements it by 1. In either case, if the reference count becomes 0,
662close-shared-library frees all memory resources consumed library and causes
663any EXTERNAL-ENTRY-POINTs known to be defined by it to become unresolved."
[6]664  (let* ((lib (if (typep lib 'string)
665                  (or (shared-library-with-name lib)
666                      (error "Shared library ~s not found." lib))
667                (require-type lib 'shlib))))
668    ;; no possible danger closing libsystem since dylibs can't be closed
669    (cond
670     ((or (not (shlib.map lib)) (not (shlib.base lib)))
671      (error "Shared library ~s uninitialized." (shlib.soname lib)))
672     ((and (not (%null-ptr-p (shlib.map lib)))
673           (%null-ptr-p (shlib.base lib)))
674      (warn "Dynamic libraries cannot be closed on Darwin."))
675     ((and (%null-ptr-p (shlib.map lib))
676           (not (%null-ptr-p (shlib.base lib))))
[1958]677      ;; we have a bundle type library not sure what to do with the
678      ;; completely flag when we open the same bundle more than once,
679      ;; Darwin gives back a new module address, so we have multiple
680      ;; entries on *shared-libraries* the best we can do is unlink
681      ;; the module asked for (or our best guess based on name) and
682      ;; invalidate any entries which refer to this container
[6]683      (if (= 0 (#_NSUnLinkModule (shlib.base lib) #$NSUNLINKMODULE_OPTION_NONE))
684          (error "Unable to close shared library, NSUnlinkModule failed.")
685        (progn
686          (setf (shlib.map lib) nil
687                (shlib.base lib) nil)
688          (unload-library-entrypoints lib)
689          (when completely
690            (setq *shared-libraries* (delete lib *shared-libraries*)))))))))
691
692
693
694;;; Foreign (unix) processes.
695
696(defun call-with-string-vector (function strings)
697  (let ((bufsize (reduce #'+ strings
698                         :key #'(lambda (s) (1+ (length (string s))))))
[1958]699        (argvsize (ash (1+ (length strings)) target::word-shift))
[6]700        (bufpos 0)
701        (argvpos 0))
702    (%stack-block ((buf bufsize) (argv argvsize))
703      (flet ((init (s)
704             (multiple-value-bind (sstr start end) (get-sstring s)
[5120]705               (declare (fixnum start end))
[6]706               (let ((len (- end start)))
[5120]707                 (declare (fixnum len))
708                 (do* ((i 0 (1+ i))
709                       (start start (1+ start))
710                       (bufpos bufpos (1+ bufpos)))
711                      ((= i len))
712                   (setf (%get-unsigned-byte buf bufpos)
713                         (logand #xff (%scharcode sstr start))))
[6]714                 (setf (%get-byte buf (%i+ bufpos len)) 0)
715                 (setf (%get-ptr argv argvpos) (%inc-ptr buf bufpos))
716                 (setq bufpos (%i+ bufpos len 1))
[1958]717                 (setq argvpos (%i+ argvpos target::node-size))))))
[6]718        (declare (dynamic-extent #'init))
719        (map nil #'init strings))
720      (setf (%get-ptr argv argvpos) (%null-ptr))
721      (funcall function argv))))
722
723(defmacro with-string-vector ((var &rest strings) &body body)
724  `(call-with-string-vector #'(lambda (,var) ,@body) ,@strings))
725
726(defloadvar *max-os-open-files* (#_getdtablesize))
727
728(defun %execvp (argv)
729  (#_execvp (%get-ptr argv) argv)
730  (#_exit #$EX_OSERR))
731
732(defun exec-with-io-redirection (new-in new-out new-err argv)
733  (#_setpgid 0 0)
734  (if new-in (#_dup2 new-in 0))
735  (if new-out (#_dup2 new-out 1))
736  (if new-err (#_dup2 new-err 2))
737  (do* ((fd 3 (1+ fd)))
738       ((= fd *max-os-open-files*) (%execvp argv))
739    (declare (fixnum fd))
740    (#_close fd)))
741
742
743
744
[1958]745
[7624]746
[4857]747;;; I believe that the Darwin/FreeBSD syscall infterface is rather ... odd.
[1958]748;;; Use libc's interface.
[6]749(defun pipe ()
[7624]750  ;;  (rlet ((filedes (:array :int 2)))
[6200]751  (%stack-block ((filedes 8))
[7624]752    (let* ((status (#_pipe filedes))
753           (errno (if (eql status 0) 0 (%get-errno))))
754      (unless (zerop status)
755        (when (or (eql errno (- #$EMFILE))
756                  (eql errno (- #$ENFILE)))
757          (gc)
758          (drain-termination-queue)
759          (setq status (#_pipe filedes)
760                errno (if (zerop status) 0 (%get-errno)))))
[1958]761      (if (zerop status)
[6200]762        (values (paref filedes (:array :int)  0) (paref filedes (:array :int)  1))
[7624]763        (%errno-disp errno)))))
[6]764
765
[1958]766
[6]767(defstruct external-process
768  pid
769  %status
770  %exit-code
771  pty
772  input
773  output
774  error
775  status-hook
776  plist
777  token
778  core
779  args
780  (signal (make-semaphore))
[824]781  (completed (make-semaphore))
782  watched-fd
783  watched-stream
[6]784  )
785
786(defmethod print-object ((p external-process) stream)
787  (print-unreadable-object (p stream :type t :identity t)
788    (let* ((status (external-process-%status p)))
789      (let* ((*print-length* 3))
790        (format stream "~a" (external-process-args p)))
791      (format stream "[~d] (~a" (external-process-pid p) status)
792      (unless (eq status :running)
793        (format stream " : ~d" (external-process-%exit-code p)))
794      (format stream ")"))))
795
[824]796(defun get-descriptor-for (object proc close-in-parent close-on-error
[7211]797                                  &rest keys &key direction (element-type 'character)
[6]798                                  &allow-other-keys)
799  (etypecase object
800    ((eql t)
801     (values nil nil close-in-parent close-on-error))
802    (null
803     (let* ((fd (fd-open "/dev/null" (case direction
804                                       (:input #$O_RDONLY)
805                                       (:output #$O_WRONLY)
806                                       (t #$O_RDWR)))))
807       (if (< fd 0)
808         (signal-file-error fd "/dev/null"))
[4385]809       (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
[6]810    ((eql :stream)
811     (multiple-value-bind (read-pipe write-pipe) (pipe)
812       (case direction
813         (:input
814          (values read-pipe
815                  (make-fd-stream write-pipe
816                                  :direction :output
[7211]817                                  :element-type element-type
[7265]818                                  :interactive nil
[7624]819                                  :basic t
820                                  :auto-close t)
[6]821                  (cons read-pipe close-in-parent)
822                  (cons write-pipe close-on-error)))
823         (:output
824          (values write-pipe
825                  (make-fd-stream read-pipe
826                                  :direction :input
[7211]827                                  :element-type element-type
[7265]828                                  :interactive nil
[7624]829                                  :basic t
830                                  :auto-close t)
[6]831                  (cons write-pipe close-in-parent)
832                  (cons read-pipe close-on-error)))
833         (t
834          (fd-close read-pipe)
835          (fd-close write-pipe)
836          (report-bad-arg direction '(member :input :output))))))
837    ((or pathname string)
838     (with-open-stream (file (apply #'open object keys))
[4900]839       (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)))))
[4385]840         (values fd
841                 nil
842                 (cons fd close-in-parent)
843                 (cons fd close-on-error)))))
[6]844    (fd-stream
[4900]845     (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
[4385]846       (values fd
[6]847               nil
[4385]848               (cons fd close-in-parent)
849               (cons fd close-on-error))))
[6]850    (stream
851     (ecase direction
852       (:input
853        (with-cstrs ((template "lisp-tempXXXXXX"))
854          (let* ((fd (#_mkstemp template)))
855            (if (< fd 0)
856              (%errno-disp fd))
857            (#_unlink template)
858            (loop
[4385]859              (multiple-value-bind (line no-newline)
860                  (read-line object nil nil)
861                (unless line
862                  (return))
863                (let* ((len (length line)))
864                  (%stack-block ((buf (1+ len)))
[5143]865                    (%cstr-pointer line buf)
[4385]866                    (fd-write fd buf len)
867                    (if no-newline
868                      (return))
869                    (setf (%get-byte buf) (char-code #\newline))
870                    (fd-write fd buf 1)))))
[6]871            (fd-lseek fd 0 #$SEEK_SET)
[4385]872            (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))))
[6]873       (:output
874        (multiple-value-bind (read-pipe write-pipe) (pipe)
[824]875          (setf (external-process-watched-fd proc) read-pipe
876                (external-process-watched-stream proc) object)
877          (incf (car (external-process-token proc)))
[6]878          (values write-pipe
879                  nil
880                  (cons write-pipe close-in-parent)
881                  (cons read-pipe close-on-error))))))))
882
883(let* ((external-processes ())
[824]884       (external-processes-lock (make-lock)))
[6]885  (defun add-external-process (p)
886    (with-lock-grabbed (external-processes-lock)
887      (push p external-processes)))
888  (defun remove-external-process (p)
889    (with-lock-grabbed (external-processes-lock)
890      (setq external-processes (delete p external-processes))))
891  ;; Likewise
892  (defun external-processes ()
893    (with-lock-grabbed (external-processes-lock)
894      (copy-list external-processes)))
895  )
896
897
[8241]898(defmacro wtermsig (status)
899  `(ldb (byte 7 0) ,status))
[6]900
[8241]901(defmacro wexitstatus (status)
902  `(ldb (byte 8 8) (the fixnum ,status)))
903
904(defmacro wstopsig (status)
905  `(wexitstatus ,status))
906
907(defmacro wifexited (status)
908  `(eql (wtermsig ,status) 0))
909
910(defmacro wifstopped (status)
911  `(eql #x7f (ldb (byte 7 0) (the fixnum ,status))))
912
[824]913(defun monitor-external-process (p)
914  (let* ((in-fd (external-process-watched-fd p))
915         (out-stream (external-process-watched-stream p))
916         (token (external-process-token p))
917         (terminated))
[8271]918    (loop
919      (when (and terminated (null in-fd))
920        (signal-semaphore (external-process-completed p))
921        (return))
922      (when in-fd
[8487]923        (when (fd-input-available-p in-fd 1000)
[8271]924          (%stack-block ((buf 1024))
925            (let* ((n (fd-read in-fd buf 1024)))
926              (declare (fixnum n))
927              (if (<= n 0)
928                (progn
929                  (without-interrupts
930                   (decf (car token))
931                   (fd-close in-fd)
932                   (setq in-fd nil)))
933                (let* ((string (make-string 1024)))
934                  (declare (dynamic-extent string))
935                  (%str-from-ptr buf n string)
936                  (write-sequence string out-stream :end n)))))))
937      (let* ((statusflags (check-pid (external-process-pid p)
938                                     (logior
939                                      (if in-fd #$WNOHANG 0)
940                                      #$WUNTRACED)))
941             (oldstatus (external-process-%status p)))
942        (cond ((null statusflags)
943               (remove-external-process p)
944               (setq terminated t))
945              ((eq statusflags t))      ; Running.
946              (t
947               (multiple-value-bind (status code core)
948                   (cond ((wifstopped statusflags)
949                          (values :stopped (wstopsig statusflags)))
950                         ((wifexited statusflags)
951                          (values :exited (wexitstatus statusflags)))
952                         (t
953                          (let* ((signal (wtermsig statusflags)))
954                            (declare (fixnum signal))
955                            (values
956                             (if (or (= signal #$SIGSTOP)
957                                     (= signal #$SIGTSTP)
958                                     (= signal #$SIGTTIN)
959                                     (= signal #$SIGTTOU))
960                               :stopped
961                               :signaled)
962                             signal
[10053]963                             (logtest #-solaris-target #$WCOREFLAG
964                                      #+solaris-target #$WCOREFLG
965                                      statusflags)))))
[8271]966                 (setf (external-process-%status p) status
967                       (external-process-%exit-code p) code
968                       (external-process-core p) core)
969                 (let* ((status-hook (external-process-status-hook p)))
970                   (when (and status-hook (not (eq oldstatus status)))
971                     (funcall status-hook p)))
972                 (when (or (eq status :exited)
973                           (eq status :signaled))
974                   (remove-external-process p)
975                   (setq terminated t)))))))))
[824]976     
[7308]977(defun run-external-process (proc in-fd out-fd error-fd &optional env)
978  ;; type-check the env variable
979  (dolist (pair env)
980    (destructuring-bind (var . val) pair
981      (assert (typep var '(or string symbol character)))
982      (assert (typep val 'string)))) 
[6]983  (call-with-string-vector
984   #'(lambda (argv)
985       (let* ((child-pid (#_fork)))
986         (declare (fixnum child-pid))
987         (cond ((zerop child-pid)
988                ;; Running in the child; do an exec
[7308]989                (dolist (pair env)
990                  (setenv (string (car pair)) (cdr pair)))
[6]991                (without-interrupts
992                 (exec-with-io-redirection
993                  in-fd out-fd error-fd argv)))
994               ((> child-pid 0)
995                ;; Running in the parent: success
996                (setf (external-process-pid proc) child-pid)
[824]997                (add-external-process proc)
[6]998                (signal-semaphore (external-process-signal proc))
[8963]999                (monitor-external-process proc))
1000               (t
1001                ;; Fork failed
1002                (setf (external-process-%status proc) :error
1003                      (external-process-%exit-code proc) (%get-errno))
1004                (signal-semaphore (external-process-signal proc))))))
[6]1005   (external-process-args proc)))
1006
1007               
1008(defun run-program (program args &key
1009                            (wait t) pty
1010                            input if-input-does-not-exist
1011                            output (if-output-exists :error)
1012                            (error :output) (if-error-exists :error)
[7308]1013                            status-hook (element-type 'character)
1014                            env)
[2441]1015  "Invoke an external program as an OS subprocess of lisp."
[6]1016  (declare (ignore pty))
1017  (unless (every #'(lambda (a) (typep a 'simple-string)) args)
1018    (error "Program args must all be simple strings : ~s" args))
[6947]1019  (push (native-untranslated-namestring program) args)
[6]1020  (let* ((token (list 0))
1021         (in-fd nil)
1022         (in-stream nil)
1023         (out-fd nil)
1024         (out-stream nil)
1025         (error-fd nil)
1026         (error-stream nil)
1027         (close-in-parent nil)
1028         (close-on-error nil)
[824]1029         (proc
1030          (make-external-process
1031           :pid nil
1032           :args args
1033           :%status :running
1034           :input nil
1035           :output nil
1036           :error nil
1037           :token token
1038           :status-hook status-hook)))
[6]1039    (unwind-protect
1040         (progn
1041           (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
[824]1042             (get-descriptor-for input proc  nil nil :direction :input
[7211]1043                                 :if-does-not-exist if-input-does-not-exist
1044                                 :element-type element-type))
[6]1045           (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
[824]1046             (get-descriptor-for output proc close-in-parent close-on-error
[6]1047                                 :direction :output
[7211]1048                                 :if-exists if-output-exists
1049                                 :element-type element-type))
[6]1050           (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
1051             (if (eq error :output)
1052               (values out-fd out-stream close-in-parent close-on-error)
[824]1053               (get-descriptor-for error proc close-in-parent close-on-error
[6]1054                                   :direction :output
[7211]1055                                   :if-exists if-error-exists
1056                                   :element-type element-type)))
[824]1057           (setf (external-process-input proc) in-stream
1058                 (external-process-output proc) out-stream
1059                 (external-process-error proc) error-stream)
1060           (process-run-function
1061            (format nil "Monitor thread for external process ~a" args)
1062                   
[7308]1063            #'run-external-process proc in-fd out-fd error-fd env)
[824]1064           (wait-on-semaphore (external-process-signal proc))
[4034]1065           )
1066      (dolist (fd close-in-parent) (fd-close fd))
1067      (unless (external-process-pid proc)
1068        (dolist (fd close-on-error) (fd-close fd)))
1069      (when (and wait (external-process-pid proc))
[4636]1070        (with-interrupts-enabled
1071            (wait-on-semaphore (external-process-completed proc)))))
[8963]1072    (and (or (external-process-pid proc)
1073             (if (eq (external-process-%status proc) :error)
1074               (error "Fork failed in ~s: ~s" proc (%strerror (external-process-%exit-code proc)))))
1075             (external-process-%status proc)) proc))
[6]1076
1077
1078
1079
1080(defmacro wifsignaled (status)
1081  (let* ((statname (gensym)))
1082    `(let* ((,statname ,status))
1083      (and (not (wifstopped ,statname)) (not (wifexited ,statname))))))
1084
1085
1086(defun check-pid (pid &optional (flags (logior  #$WNOHANG #$WUNTRACED)))
1087  (declare (fixnum pid))
1088  (rlet ((status :signed))
[8990]1089    (let* ((retval (ff-call-ignoring-eintr (#_waitpid pid status flags))))
[6]1090      (declare (fixnum retval))
1091      (if (= retval pid)
1092        (pref status :signed)
1093        (zerop retval)))))
1094
1095
1096
1097
1098
1099(defun external-process-wait (proc &optional check-stopped)
1100  (process-wait "external-process-wait"
1101                #'(lambda ()
1102                    (case (external-process-%status proc)
1103                      (:running)
1104                      (:stopped
1105                       (when check-stopped
1106                         t))
1107                      (t
1108                       (when (zerop (car (external-process-token proc)))
1109                         t))))))
1110
1111(defun external-process-status (proc)
[2441]1112  "Return information about whether an OS subprocess is running; or, if
1113not, why not; and what its result code was if it completed."
[6]1114  (require-type proc 'external-process)
1115  (values (external-process-%status proc)
1116          (external-process-%exit-code proc)))
1117
1118(defun external-process-input-stream (proc)
[2441]1119  "Return the lisp stream which is used to write input to a given OS
1120subprocess, if it has one."
[6]1121  (require-type proc 'external-process)
1122  (external-process-input proc))
1123
1124(defun external-process-output-stream (proc)
[2441]1125  "Return the lisp stream which is used to read output from a given OS
1126subprocess, if there is one."
[6]1127  (require-type proc 'external-process)
1128  (external-process-output proc))
1129
1130(defun external-process-error-stream (proc)
[2441]1131  "Return the stream which is used to read error output from a given OS
1132subprocess, if it has one."
[6]1133  (require-type proc 'external-process)
1134  (external-process-error proc))
1135
1136(defun external-process-id (proc)
[2441]1137  "Return the process id of an OS subprocess, a positive integer which
1138identifies it."
[6]1139  (require-type proc 'external-process)
1140  (external-process-pid proc))
1141 
1142(defun signal-external-process (proc signal)
[2441]1143  "Send the specified signal to the specified external process.  (Typically,
1144it would only be useful to call this function if the EXTERNAL-PROCESS was
1145created with :WAIT NIL.) Return T if successful; signal an error otherwise."
[6]1146  (require-type proc 'external-process)
1147  (let* ((pid (external-process-pid proc))
[1546]1148         (error (syscall syscalls::kill pid signal)))
[6]1149    (or (eql error 0)
1150        (%errno-disp error))))
1151
1152;;; EOF on a TTY is transient, but I'm less sure of other cases.
1153(defun eof-transient-p (fd)
1154  (case (%unix-fd-kind fd)
1155    (:tty t)
1156    (t nil)))
[475]1157
1158
1159(defstruct (shared-resource (:constructor make-shared-resource (name)))
1160  (name)
1161  (lock (make-lock))
1162  (primary-owner *current-process*)
1163  (primary-owner-notify (make-semaphore))
1164  (current-owner nil)
1165  (requestors (make-dll-header)))
1166
1167(defstruct (shared-resource-request
1168             (:constructor make-shared-resource-request (process))
1169             (:include dll-node))
1170  process
1171  (signal (make-semaphore)))
1172             
1173
1174;; Returns NIL if already owned by calling thread, T otherwise
1175(defun %acquire-shared-resource (resource  &optional verbose)
1176  (let* ((current *current-process*))
1177    (with-lock-grabbed ((shared-resource-lock resource))
1178      (let* ((secondary (shared-resource-current-owner resource)))
1179        (if (or (eq current secondary)
1180                (and (null secondary)
1181                     (eq current (shared-resource-primary-owner resource))))
1182          (return-from %acquire-shared-resource nil))))
1183    (let* ((request (make-shared-resource-request *current-process*)))
1184      (when verbose
1185        (format t "~%~%;;;~%;;; ~a requires access to ~a~%;;;~%~%"
1186                *current-process* (shared-resource-name resource)))
1187      (with-lock-grabbed ((shared-resource-lock resource))
1188        (append-dll-node request (shared-resource-requestors resource)))
1189      (wait-on-semaphore (shared-resource-request-signal request))
[512]1190      (assert (eq current (shared-resource-current-owner resource)))
[475]1191      (when verbose
1192        (format t "~%~%;;;~%;;; ~a is now owned by ~a~%;;;~%~%"
1193                (shared-resource-name resource) current))
1194      t)))
1195
1196;;; If we're the primary owner and there is no secondary owner, do nothing.
1197;;; If we're the secondary owner, cease being the secondary owner.
1198(defun %release-shared-resource (r)
1199  (let* ((not-any-owner ()))
1200    (with-lock-grabbed ((shared-resource-lock r))
1201      (let* ((current *current-process*)
1202             (primary (shared-resource-primary-owner r))
1203             (secondary (shared-resource-current-owner r)))
1204        (unless (setq not-any-owner
[512]1205                      (not (or (eq current secondary)
1206                               (and (null secondary)
1207                                    (eq current primary)))))
1208          (when (eq current secondary)
[475]1209            (setf (shared-resource-current-owner r) nil)
1210            (signal-semaphore (shared-resource-primary-owner-notify r))))))
1211    (when not-any-owner
1212      (signal-program-error "Process ~a does not own ~a" *current-process*
1213                            (shared-resource-name r)))))
1214
1215;;; The current thread should be the primary owner; there should be
1216;;; no secondary owner.  Wakeup the specified (or first) requesting
1217;;; process, then block on our semaphore
1218(defun %yield-shared-resource (r &optional to)
1219  (let* ((request nil))
1220    (with-lock-grabbed ((shared-resource-lock r))
1221      (let* ((current *current-process*)
1222             (primary (shared-resource-primary-owner r)))
1223        (when (and (eq current primary)
1224                   (null (shared-resource-current-owner r)))
1225          (setq request
1226                (let* ((header (shared-resource-requestors r)))
1227                  (if to 
1228                    (do-dll-nodes (node header)
1229                      (when (eq to (shared-resource-request-process node))
1230                        (return node)))
1231                    (let* ((first (dll-header-first header)))
1232                      (unless (eq first header)
1233                        first)))))
1234          (when request
1235            (remove-dll-node request)
[512]1236            (setf (shared-resource-current-owner r)
1237                  (shared-resource-request-process request))
[475]1238            (signal-semaphore (shared-resource-request-signal request))))))
1239    (when request
1240      (wait-on-semaphore (shared-resource-primary-owner-notify r))
[512]1241      (format t "~%;;;~%;;;control of ~a restored to ~a~%;;;~&"
[475]1242              (shared-resource-name r)
1243              *current-process*))))
1244
1245
1246     
1247
1248(defun %shared-resource-requestor-p (r proc)
1249  (with-lock-grabbed ((shared-resource-lock r))
1250    (do-dll-nodes (node (shared-resource-requestors r))
1251      (when (eq proc (shared-resource-request-process node))
1252        (return t)))))
1253
[2363]1254(defparameter *resident-editor-hook* nil
1255  "If non-NIL, should be a function that takes an optional argument
1256   (like ED) and invokes a \"resident\" editor.")
1257
1258(defun ed (&optional arg)
1259  (if *resident-editor-hook*
1260    (funcall *resident-editor-hook* arg)
1261    (error "This implementation doesn't provide a resident editor.")))
1262
1263(defun running-under-emacs-p ()
1264  (not (null (getenv "EMACS"))))
1265
1266(defloadvar *cpu-count* nil)
1267
1268(defun cpu-count ()
1269  (or *cpu-count*
1270      (setq *cpu-count*
[4994]1271            #+darwin-target
[2363]1272            (rlet ((info :host_basic_info)
1273                   (count :mach_msg_type_number_t #$HOST_BASIC_INFO_COUNT))
1274              (if (eql #$KERN_SUCCESS (#_host_info (#_mach_host_self)
1275                                                   #$HOST_BASIC_INFO
1276                                                   info
1277                                                   count))
1278                (pref info :host_basic_info.max_cpus)
1279                1))
[10053]1280            #+(or linux-target solaris-target)
[2363]1281            (or
[5998]1282             (let* ((n (#_sysconf #$_SC_NPROCESSORS_ONLN)))
1283               (declare (fixnum n))
1284               (if (> n 0) n))
[10053]1285             #+linux-target
[2363]1286             (ignore-errors
1287               (with-open-file (p "/proc/cpuinfo")
1288                 (let* ((ncpu 0)
1289                        (match "processor")
1290                        (matchlen (length match)))
1291                   (do* ((line (read-line p nil nil) (read-line p nil nil)))
1292                        ((null line) ncpu)
1293                     (let* ((line-length (length line)))
1294                       (when (and
1295                              (> line-length matchlen)
[2364]1296                              (string= match line
[2363]1297                                       :end2 matchlen)
1298                              (whitespacep (schar line matchlen)))
1299                         (incf ncpu)))))))
[4828]1300             1)
1301            #+freebsd-target
[6496]1302            (rlet ((ret :uint))
1303              (%stack-block ((mib (* (record-length :uint) 2)))
1304              (setf (paref mib (:array :uint) 0)
[4828]1305                    #$CTL_HW
[6496]1306                    (paref mib (:array :uint) 1)
[4828]1307                    #$HW_NCPU)
1308              (rlet ((oldsize :uint (record-length :uint)))
1309                (if (eql 0 (#_sysctl mib 2 ret oldsize (%null-ptr) 0))
1310                  (pref ret :uint)
[6496]1311                  1))))
[4828]1312            )))
[5984]1313
1314(def-load-pointers spin-count ()
1315  (if (eql 1 (cpu-count))
[6496]1316    (%defglobal '*spin-lock-tries* 1)
[7624]1317    (%defglobal '*spin-lock-tries* 1024))
1318  (%defglobal '*spin-lock-timeouts* 0))
[5984]1319
1320(defun yield ()
1321  (#_sched_yield))
[6496]1322
1323(defloadvar *host-page-size* (#_getpagesize))
1324
1325;;(assert (= (logcount *host-page-size*) 1))
1326
1327(defun map-file-to-ivector (pathname element-type)
1328  (let* ((upgraded-type (upgraded-array-element-type element-type))
1329         (upgraded-ctype (specifier-type upgraded-type)))
1330    (unless (and (typep upgraded-ctype 'numeric-ctype)
1331                 (eq 'integer (numeric-ctype-class upgraded-ctype)))
1332      (error "Invalid element-type: ~s" element-type))
1333    (let* ((bits-per-element (integer-length (- (numeric-ctype-high upgraded-ctype)
1334                                                (numeric-ctype-low upgraded-ctype))))
1335           (fd (fd-open (native-translated-namestring pathname) #$O_RDONLY)))
1336      (if (< fd 0)
1337        (signal-file-error fd pathname)
1338        (let* ((len (fd-size fd)))
1339          (if (< len 0)
1340            (signal-file-error fd pathname)
1341            (let* ((nbytes (+ *host-page-size*
1342                              (logandc2 (+ len
1343                                           (1- *host-page-size*))
1344                                        (1- *host-page-size*))))
1345
1346                   (ndata-elements
1347                    (ash len
1348                         (ecase bits-per-element
1349                           (1 3)
1350                           (8 0)
1351                           (16 -1)
1352                           (32 -2)
1353                           (64 -3))))
1354                   (nalignment-elements
1355                    (ash target::nbits-in-word
1356                         (ecase bits-per-element
1357                           (1 0)
1358                           (8 -3)
1359                           (16 -4)
1360                           (32 -5)
1361                           (64 -6)))))
1362              (if (>= (+ ndata-elements nalignment-elements)
1363                      array-total-size-limit)
1364                (progn
1365                  (fd-close fd)
1366                  (error "Can't make a vector with ~s elements in this implementation." (+ ndata-elements nalignment-elements)))
[8398]1367                (let* ((addr (#_mmap (%null-ptr)
[6496]1368                                     nbytes
1369                                     #$PROT_NONE
1370                                     (logior #$MAP_ANON #$MAP_PRIVATE)
1371                                     -1
1372                                     0)))             
1373                  (if (eql addr (%int-to-ptr (1- (ash 1 target::nbits-in-word)))) ; #$MAP_FAILED
1374                    (let* ((errno (%get-errno)))
1375                      (fd-close fd)
1376                      (error "Can't map ~d bytes: ~a" nbytes (%strerror errno)))
1377              ;;; Remap the first page so that we can put a vector header
1378              ;;; there; use the first word on the first page to remember
1379              ;;; the file descriptor.
1380                    (progn
1381                      (#_mmap addr
1382                              *host-page-size*
1383                              (logior #$PROT_READ #$PROT_WRITE)
1384                              (logior #$MAP_ANON #$MAP_PRIVATE #$MAP_FIXED)
1385                              -1
1386                              0)
1387                      (setf (pref addr :int) fd)
1388                      (let* ((header-addr (%inc-ptr addr (- *host-page-size*
1389                                                            (* 2 target::node-size)))))
1390                        (setf (pref header-addr :unsigned-long)
1391                              (logior (element-type-subtype upgraded-type)
1392                                      (ash (+ ndata-elements nalignment-elements) target::num-subtag-bits)))
1393                        (when (> len 0)
1394                          (let* ((target-addr (%inc-ptr header-addr (* 2 target::node-size))))
1395                            (unless (eql target-addr
1396                                         (#_mmap target-addr
1397                                                 len
1398                                                 #$PROT_READ
1399                                                 (logior #$MAP_PRIVATE #$MAP_FIXED)
1400                                                 fd
1401                                                 0))
1402                              (let* ((errno (%get-errno)))
1403                                (fd-close fd)
1404                                (#_munmap addr nbytes)
1405                                (error "Mapping failed: ~a" (%strerror errno))))))
1406                        (with-macptrs ((v (%inc-ptr header-addr target::fulltag-misc)))
1407                          (let* ((vector (rlet ((p :address v)) (%get-object p 0))))
1408                            ;; Tell some parts of OpenMCL - notably the
1409                            ;; printer - that this thing off in foreign
1410                            ;; memory is a real lisp object and not
1411                            ;; "bogus".
1412                            (with-lock-grabbed (*heap-ivector-lock*)
1413                              (push vector *heap-ivectors*))
1414                            (make-array ndata-elements
1415                                        :element-type upgraded-type
1416                                        :displaced-to vector
1417                                        :adjustable t
1418                                        :displaced-index-offset nalignment-elements)))))))))))))))
1419
1420(defun map-file-to-octet-vector (pathname)
1421  (map-file-to-ivector pathname '(unsigned-byte 8)))
1422
1423(defun mapped-vector-data-address-and-size (displaced-vector)
1424  (let* ((v (array-displacement displaced-vector))
1425         (element-type (array-element-type displaced-vector)))
1426    (if (or (eq v displaced-vector)
1427            (not (with-lock-grabbed (*heap-ivector-lock*)
1428                   (member v *heap-ivectors*))))
1429      (error "~s doesn't seem to have been allocated via ~s and not yet unmapped" displaced-vector 'map-file-to-ivector))
1430    (let* ((pv (rlet ((x :address)) (%set-object x 0 v) (pref x :address)))
1431           (ctype (specifier-type element-type))
1432           (arch (backend-target-arch *target-backend*)))
1433      (values (%inc-ptr pv (- (* 2 target::node-size) target::fulltag-misc))
1434              (- (funcall (arch::target-array-data-size-function arch)
1435                          (ctype-subtype ctype)
1436                          (length v))
1437                 target::node-size)))))
1438
1439 
1440;;; Argument should be something returned by MAP-FILE-TO-IVECTOR;
1441;;; this should be called at most once for any such object.
1442(defun unmap-ivector (displaced-vector)
1443  (multiple-value-bind (data-address size-in-octets)
1444      (mapped-vector-data-address-and-size displaced-vector)
1445  (let* ((v (array-displacement displaced-vector))
1446         (base-address (%inc-ptr data-address (- *host-page-size*)))
1447         (fd (pref base-address :int)))
1448      (let* ((element-type (array-element-type displaced-vector)))
1449        (adjust-array displaced-vector 0
1450                      :element-type element-type
1451                      :displaced-to (make-array 0 :element-type element-type)
1452                      :displaced-index-offset 0))
1453      (with-lock-grabbed (*heap-ivector-lock*)
1454        (setq *heap-ivectors* (delete v *heap-ivectors*)))
1455      (#_munmap base-address (+ size-in-octets *host-page-size*))     
1456      (fd-close fd)
1457      t)))
1458
1459(defun unmap-octet-vector (v)
1460  (unmap-ivector v))
1461
1462(defun lock-mapped-vector (v)
1463  (multiple-value-bind (address nbytes)
1464      (mapped-vector-data-address-and-size v)
1465    (eql 0 (#_mlock address nbytes))))
1466
1467(defun unlock-mapped-vector (v)
1468  (multiple-value-bind (address nbytes)
1469      (mapped-vector-data-address-and-size v)
1470    (eql 0 (#_munlock address nbytes))))
1471
1472(defun bitmap-for-mapped-range (address nbytes)
1473  (let* ((npages (ceiling nbytes *host-page-size*)))
1474    (%stack-block ((vec npages))
1475      (when (eql 0 (#_mincore address nbytes vec))
1476        (let* ((bits (make-array npages :element-type 'bit)))
1477          (dotimes (i npages bits)
1478            (setf (sbit bits i)
1479                  (logand 1 (%get-unsigned-byte vec i)))))))))
1480
1481(defun percentage-of-resident-pages (address nbytes)
1482  (let* ((npages (ceiling nbytes *host-page-size*)))
1483    (%stack-block ((vec npages))
1484      (when (eql 0 (#_mincore address nbytes vec))
1485        (let* ((nresident 0))
1486          (dotimes (i npages (* 100.0 (/ nresident npages)))
1487            (when (logbitp 0 (%get-unsigned-byte vec i))
1488              (incf nresident))))))))
1489
1490(defun mapped-vector-resident-pages (v)
1491  (multiple-value-bind (address nbytes)
1492      (mapped-vector-data-address-and-size v)
1493    (bitmap-for-mapped-range address nbytes)))
1494
1495(defun mapped-vector-resident-pages-percentage (v)
1496  (multiple-value-bind (address nbytes)
1497      (mapped-vector-data-address-and-size v)
1498    (percentage-of-resident-pages address nbytes)))
1499 
[7420]1500#+x86-target
1501(progn
1502(defloadvar *last-rdtsc-time* 0)
1503
1504(defstatic *rdtsc-estimated-increment* 1 "Should be positive ...")
1505
1506(defun rdtsc-monotonic ()
1507  "Return monotonically increasing values, partly compensating for
1508   OSes that don't keep the TSCs of all processorsin synch."
1509  (loop
1510    (let* ((old *last-rdtsc-time*)
1511           (new (rdtsc)))
1512      (when (< new old)
1513        ;; We're running on a CPU whose TSC is behind the one
1514        ;; on the last CPU we were scheduled on.
1515        (setq new (+ old *rdtsc-estimated-increment*)))
1516      (when (%store-node-conditional target::symbol.vcell *last-rdtsc-time* old new)
1517        (return new)))))
1518
1519(defun estimate-rdtsc-skew (&optional (niter 1000000))
1520  (do* ((i 0 (1+ i))
1521        (last (rdtsc) next)
1522        (next (rdtsc) (rdtsc))
1523        (skew 1))
1524       ((>= i niter) (setq *rdtsc-estimated-increment* skew))
1525    (declare (fixnum last next skew))
1526    (when (> last next)
1527      (let* ((s (- last next)))
1528        (declare (fixnum s))
1529        (when (> s skew) (setq skew s))))))
1530)
1531
1532
Note: See TracBrowser for help on using the repository browser.