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

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

Conditionalize for Solaris.

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