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

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

Use (%null-ptr) in lieu of +null-ptr+

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