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

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

GET-USER-HOME-DIR: Solaris backward-compatibility lossage.

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