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

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

Use reentrant version of #_readdir.
Need a new canonical foreign-type ordinal for that.
This is a little tricky to bootstrap, so new images.

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