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

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

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

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