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

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

When creating a thread to moniitor an external process, make
its stacks small (128KB each), which is probably way too
large but which may avoid problems if default stack sizes
are very large and many external processes are running
simulaneously.

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