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

Last change on this file since 8345 was 8345, checked in by gz, 12 years ago

Just use %get-errno, duh

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