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

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

Replace syscall with int-errno call. See what breaks ...

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 54.1 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            (format nil "Monitor thread for external process ~a" args)
1031                   
1032            #'run-external-process proc in-fd out-fd error-fd env)
1033           (wait-on-semaphore (external-process-signal proc))
1034           )
1035      (dolist (fd close-in-parent) (fd-close fd))
1036      (unless (external-process-pid proc)
1037        (dolist (fd close-on-error) (fd-close fd)))
1038      (when (and wait (external-process-pid proc))
1039        (with-interrupts-enabled
1040            (wait-on-semaphore (external-process-completed proc)))))
1041    (and (or (external-process-pid proc)
1042             (if (eq (external-process-%status proc) :error)
1043               (error "Fork failed in ~s: ~s" proc (%strerror (external-process-%exit-code proc)))))
1044             (external-process-%status proc)) proc))
1045
1046
1047
1048
1049(defmacro wifsignaled (status)
1050  (let* ((statname (gensym)))
1051    `(let* ((,statname ,status))
1052      (and (not (wifstopped ,statname)) (not (wifexited ,statname))))))
1053
1054
1055(defun check-pid (pid &optional (flags (logior  #$WNOHANG #$WUNTRACED)))
1056  (declare (fixnum pid))
1057  (rlet ((status :signed))
1058    (let* ((retval (ff-call-ignoring-eintr (#_waitpid pid status flags))))
1059      (declare (fixnum retval))
1060      (if (= retval pid)
1061        (pref status :signed)
1062        (zerop retval)))))
1063
1064
1065
1066
1067
1068(defun external-process-wait (proc &optional check-stopped)
1069  (process-wait "external-process-wait"
1070                #'(lambda ()
1071                    (case (external-process-%status proc)
1072                      (:running)
1073                      (:stopped
1074                       (when check-stopped
1075                         t))
1076                      (t
1077                       (when (zerop (car (external-process-token proc)))
1078                         t))))))
1079
1080(defun external-process-status (proc)
1081  "Return information about whether an OS subprocess is running; or, if
1082not, why not; and what its result code was if it completed."
1083  (require-type proc 'external-process)
1084  (values (external-process-%status proc)
1085          (external-process-%exit-code proc)))
1086
1087(defun external-process-input-stream (proc)
1088  "Return the lisp stream which is used to write input to a given OS
1089subprocess, if it has one."
1090  (require-type proc 'external-process)
1091  (external-process-input proc))
1092
1093(defun external-process-output-stream (proc)
1094  "Return the lisp stream which is used to read output from a given OS
1095subprocess, if there is one."
1096  (require-type proc 'external-process)
1097  (external-process-output proc))
1098
1099(defun external-process-error-stream (proc)
1100  "Return the stream which is used to read error output from a given OS
1101subprocess, if it has one."
1102  (require-type proc 'external-process)
1103  (external-process-error proc))
1104
1105(defun external-process-id (proc)
1106  "Return the process id of an OS subprocess, a positive integer which
1107identifies it."
1108  (require-type proc 'external-process)
1109  (external-process-pid proc))
1110 
1111(defun signal-external-process (proc signal)
1112  "Send the specified signal to the specified external process.  (Typically,
1113it would only be useful to call this function if the EXTERNAL-PROCESS was
1114created with :WAIT NIL.) Return T if successful; signal an error otherwise."
1115  (require-type proc 'external-process)
1116  (let* ((pid (external-process-pid proc)))
1117    (when pid
1118      (int-errno-call (#_kill pid signal)))))
1119
1120
1121;;; EOF on a TTY is transient, but I'm less sure of other cases.
1122(defun eof-transient-p (fd)
1123  (case (%unix-fd-kind fd)
1124    (:tty t)
1125    (t nil)))
1126
1127
1128(defstruct (shared-resource (:constructor make-shared-resource (name)))
1129  (name)
1130  (lock (make-lock))
1131  (primary-owner *current-process*)
1132  (primary-owner-notify (make-semaphore))
1133  (current-owner nil)
1134  (requestors (make-dll-header)))
1135
1136(defstruct (shared-resource-request
1137             (:constructor make-shared-resource-request (process))
1138             (:include dll-node))
1139  process
1140  (signal (make-semaphore)))
1141             
1142
1143;; Returns NIL if already owned by calling thread, T otherwise
1144(defun %acquire-shared-resource (resource  &optional verbose)
1145  (let* ((current *current-process*))
1146    (with-lock-grabbed ((shared-resource-lock resource))
1147      (let* ((secondary (shared-resource-current-owner resource)))
1148        (if (or (eq current secondary)
1149                (and (null secondary)
1150                     (eq current (shared-resource-primary-owner resource))))
1151          (return-from %acquire-shared-resource nil))))
1152    (let* ((request (make-shared-resource-request *current-process*)))
1153      (when verbose
1154        (format t "~%~%;;;~%;;; ~a requires access to ~a~%;;;~%~%"
1155                *current-process* (shared-resource-name resource)))
1156      (with-lock-grabbed ((shared-resource-lock resource))
1157        (append-dll-node request (shared-resource-requestors resource)))
1158      (wait-on-semaphore (shared-resource-request-signal request))
1159      (assert (eq current (shared-resource-current-owner resource)))
1160      (when verbose
1161        (format t "~%~%;;;~%;;; ~a is now owned by ~a~%;;;~%~%"
1162                (shared-resource-name resource) current))
1163      t)))
1164
1165;;; If we're the primary owner and there is no secondary owner, do nothing.
1166;;; If we're the secondary owner, cease being the secondary owner.
1167(defun %release-shared-resource (r)
1168  (let* ((not-any-owner ()))
1169    (with-lock-grabbed ((shared-resource-lock r))
1170      (let* ((current *current-process*)
1171             (primary (shared-resource-primary-owner r))
1172             (secondary (shared-resource-current-owner r)))
1173        (unless (setq not-any-owner
1174                      (not (or (eq current secondary)
1175                               (and (null secondary)
1176                                    (eq current primary)))))
1177          (when (eq current secondary)
1178            (setf (shared-resource-current-owner r) nil)
1179            (signal-semaphore (shared-resource-primary-owner-notify r))))))
1180    (when not-any-owner
1181      (signal-program-error "Process ~a does not own ~a" *current-process*
1182                            (shared-resource-name r)))))
1183
1184;;; The current thread should be the primary owner; there should be
1185;;; no secondary owner.  Wakeup the specified (or first) requesting
1186;;; process, then block on our semaphore
1187(defun %yield-shared-resource (r &optional to)
1188  (let* ((request nil))
1189    (with-lock-grabbed ((shared-resource-lock r))
1190      (let* ((current *current-process*)
1191             (primary (shared-resource-primary-owner r)))
1192        (when (and (eq current primary)
1193                   (null (shared-resource-current-owner r)))
1194          (setq request
1195                (let* ((header (shared-resource-requestors r)))
1196                  (if to 
1197                    (do-dll-nodes (node header)
1198                      (when (eq to (shared-resource-request-process node))
1199                        (return node)))
1200                    (let* ((first (dll-header-first header)))
1201                      (unless (eq first header)
1202                        first)))))
1203          (when request
1204            (remove-dll-node request)
1205            (setf (shared-resource-current-owner r)
1206                  (shared-resource-request-process request))
1207            (signal-semaphore (shared-resource-request-signal request))))))
1208    (when request
1209      (wait-on-semaphore (shared-resource-primary-owner-notify r))
1210      (format t "~%;;;~%;;;control of ~a restored to ~a~%;;;~&"
1211              (shared-resource-name r)
1212              *current-process*))))
1213
1214
1215     
1216
1217(defun %shared-resource-requestor-p (r proc)
1218  (with-lock-grabbed ((shared-resource-lock r))
1219    (do-dll-nodes (node (shared-resource-requestors r))
1220      (when (eq proc (shared-resource-request-process node))
1221        (return t)))))
1222
1223(defparameter *resident-editor-hook* nil
1224  "If non-NIL, should be a function that takes an optional argument
1225   (like ED) and invokes a \"resident\" editor.")
1226
1227(defun ed (&optional arg)
1228  (if *resident-editor-hook*
1229    (funcall *resident-editor-hook* arg)
1230    (error "This implementation doesn't provide a resident editor.")))
1231
1232(defun running-under-emacs-p ()
1233  (not (null (getenv "EMACS"))))
1234
1235(defloadvar *cpu-count* nil)
1236
1237(defun cpu-count ()
1238  (or *cpu-count*
1239      (setq *cpu-count*
1240            #+darwin-target
1241            (rlet ((info :host_basic_info)
1242                   (count :mach_msg_type_number_t #$HOST_BASIC_INFO_COUNT))
1243              (if (eql #$KERN_SUCCESS (#_host_info (#_mach_host_self)
1244                                                   #$HOST_BASIC_INFO
1245                                                   info
1246                                                   count))
1247                (pref info :host_basic_info.max_cpus)
1248                1))
1249            #+(or linux-target solaris-target)
1250            (or
1251             (let* ((n (#_sysconf #$_SC_NPROCESSORS_ONLN)))
1252               (declare (fixnum n))
1253               (if (> n 0) n))
1254             #+linux-target
1255             (ignore-errors
1256               (with-open-file (p "/proc/cpuinfo")
1257                 (let* ((ncpu 0)
1258                        (match "processor")
1259                        (matchlen (length match)))
1260                   (do* ((line (read-line p nil nil) (read-line p nil nil)))
1261                        ((null line) ncpu)
1262                     (let* ((line-length (length line)))
1263                       (when (and
1264                              (> line-length matchlen)
1265                              (string= match line
1266                                       :end2 matchlen)
1267                              (whitespacep (schar line matchlen)))
1268                         (incf ncpu)))))))
1269             1)
1270            #+freebsd-target
1271            (rlet ((ret :uint))
1272              (%stack-block ((mib (* (record-length :uint) 2)))
1273              (setf (paref mib (:array :uint) 0)
1274                    #$CTL_HW
1275                    (paref mib (:array :uint) 1)
1276                    #$HW_NCPU)
1277              (rlet ((oldsize :uint (record-length :uint)))
1278                (if (eql 0 (#_sysctl mib 2 ret oldsize (%null-ptr) 0))
1279                  (pref ret :uint)
1280                  1))))
1281            )))
1282
1283(def-load-pointers spin-count ()
1284  (if (eql 1 (cpu-count))
1285    (%defglobal '*spin-lock-tries* 1)
1286    (%defglobal '*spin-lock-tries* 1024))
1287  (%defglobal '*spin-lock-timeouts* 0))
1288
1289(defun yield ()
1290  (#_sched_yield))
1291
1292(defloadvar *host-page-size* (#_getpagesize))
1293
1294;;(assert (= (logcount *host-page-size*) 1))
1295
1296(defun map-file-to-ivector (pathname element-type)
1297  (let* ((upgraded-type (upgraded-array-element-type element-type))
1298         (upgraded-ctype (specifier-type upgraded-type)))
1299    (unless (and (typep upgraded-ctype 'numeric-ctype)
1300                 (eq 'integer (numeric-ctype-class upgraded-ctype)))
1301      (error "Invalid element-type: ~s" element-type))
1302    (let* ((bits-per-element (integer-length (- (numeric-ctype-high upgraded-ctype)
1303                                                (numeric-ctype-low upgraded-ctype))))
1304           (fd (fd-open (native-translated-namestring pathname) #$O_RDONLY)))
1305      (if (< fd 0)
1306        (signal-file-error fd pathname)
1307        (let* ((len (fd-size fd)))
1308          (if (< len 0)
1309            (signal-file-error fd pathname)
1310            (let* ((nbytes (+ *host-page-size*
1311                              (logandc2 (+ len
1312                                           (1- *host-page-size*))
1313                                        (1- *host-page-size*))))
1314
1315                   (ndata-elements
1316                    (ash len
1317                         (ecase bits-per-element
1318                           (1 3)
1319                           (8 0)
1320                           (16 -1)
1321                           (32 -2)
1322                           (64 -3))))
1323                   (nalignment-elements
1324                    (ash target::nbits-in-word
1325                         (ecase bits-per-element
1326                           (1 0)
1327                           (8 -3)
1328                           (16 -4)
1329                           (32 -5)
1330                           (64 -6)))))
1331              (if (>= (+ ndata-elements nalignment-elements)
1332                      array-total-size-limit)
1333                (progn
1334                  (fd-close fd)
1335                  (error "Can't make a vector with ~s elements in this implementation." (+ ndata-elements nalignment-elements)))
1336                (let* ((addr (#_mmap (%null-ptr)
1337                                     nbytes
1338                                     #$PROT_NONE
1339                                     (logior #$MAP_ANON #$MAP_PRIVATE)
1340                                     -1
1341                                     0)))             
1342                  (if (eql addr (%int-to-ptr (1- (ash 1 target::nbits-in-word)))) ; #$MAP_FAILED
1343                    (let* ((errno (%get-errno)))
1344                      (fd-close fd)
1345                      (error "Can't map ~d bytes: ~a" nbytes (%strerror errno)))
1346              ;;; Remap the first page so that we can put a vector header
1347              ;;; there; use the first word on the first page to remember
1348              ;;; the file descriptor.
1349                    (progn
1350                      (#_mmap addr
1351                              *host-page-size*
1352                              (logior #$PROT_READ #$PROT_WRITE)
1353                              (logior #$MAP_ANON #$MAP_PRIVATE #$MAP_FIXED)
1354                              -1
1355                              0)
1356                      (setf (pref addr :int) fd)
1357                      (let* ((header-addr (%inc-ptr addr (- *host-page-size*
1358                                                            (* 2 target::node-size)))))
1359                        (setf (pref header-addr :unsigned-long)
1360                              (logior (element-type-subtype upgraded-type)
1361                                      (ash (+ ndata-elements nalignment-elements) target::num-subtag-bits)))
1362                        (when (> len 0)
1363                          (let* ((target-addr (%inc-ptr header-addr (* 2 target::node-size))))
1364                            (unless (eql target-addr
1365                                         (#_mmap target-addr
1366                                                 len
1367                                                 #$PROT_READ
1368                                                 (logior #$MAP_PRIVATE #$MAP_FIXED)
1369                                                 fd
1370                                                 0))
1371                              (let* ((errno (%get-errno)))
1372                                (fd-close fd)
1373                                (#_munmap addr nbytes)
1374                                (error "Mapping failed: ~a" (%strerror errno))))))
1375                        (with-macptrs ((v (%inc-ptr header-addr target::fulltag-misc)))
1376                          (let* ((vector (rlet ((p :address v)) (%get-object p 0))))
1377                            ;; Tell some parts of OpenMCL - notably the
1378                            ;; printer - that this thing off in foreign
1379                            ;; memory is a real lisp object and not
1380                            ;; "bogus".
1381                            (with-lock-grabbed (*heap-ivector-lock*)
1382                              (push vector *heap-ivectors*))
1383                            (make-array ndata-elements
1384                                        :element-type upgraded-type
1385                                        :displaced-to vector
1386                                        :adjustable t
1387                                        :displaced-index-offset nalignment-elements)))))))))))))))
1388
1389(defun map-file-to-octet-vector (pathname)
1390  (map-file-to-ivector pathname '(unsigned-byte 8)))
1391
1392(defun mapped-vector-data-address-and-size (displaced-vector)
1393  (let* ((v (array-displacement displaced-vector))
1394         (element-type (array-element-type displaced-vector)))
1395    (if (or (eq v displaced-vector)
1396            (not (with-lock-grabbed (*heap-ivector-lock*)
1397                   (member v *heap-ivectors*))))
1398      (error "~s doesn't seem to have been allocated via ~s and not yet unmapped" displaced-vector 'map-file-to-ivector))
1399    (let* ((pv (rlet ((x :address)) (%set-object x 0 v) (pref x :address)))
1400           (ctype (specifier-type element-type))
1401           (arch (backend-target-arch *target-backend*)))
1402      (values (%inc-ptr pv (- (* 2 target::node-size) target::fulltag-misc))
1403              (- (funcall (arch::target-array-data-size-function arch)
1404                          (ctype-subtype ctype)
1405                          (length v))
1406                 target::node-size)))))
1407
1408 
1409;;; Argument should be something returned by MAP-FILE-TO-IVECTOR;
1410;;; this should be called at most once for any such object.
1411(defun unmap-ivector (displaced-vector)
1412  (multiple-value-bind (data-address size-in-octets)
1413      (mapped-vector-data-address-and-size displaced-vector)
1414  (let* ((v (array-displacement displaced-vector))
1415         (base-address (%inc-ptr data-address (- *host-page-size*)))
1416         (fd (pref base-address :int)))
1417      (let* ((element-type (array-element-type displaced-vector)))
1418        (adjust-array displaced-vector 0
1419                      :element-type element-type
1420                      :displaced-to (make-array 0 :element-type element-type)
1421                      :displaced-index-offset 0))
1422      (with-lock-grabbed (*heap-ivector-lock*)
1423        (setq *heap-ivectors* (delete v *heap-ivectors*)))
1424      (#_munmap base-address (+ size-in-octets *host-page-size*))     
1425      (fd-close fd)
1426      t)))
1427
1428(defun unmap-octet-vector (v)
1429  (unmap-ivector v))
1430
1431(defun lock-mapped-vector (v)
1432  (multiple-value-bind (address nbytes)
1433      (mapped-vector-data-address-and-size v)
1434    (eql 0 (#_mlock address nbytes))))
1435
1436(defun unlock-mapped-vector (v)
1437  (multiple-value-bind (address nbytes)
1438      (mapped-vector-data-address-and-size v)
1439    (eql 0 (#_munlock address nbytes))))
1440
1441(defun bitmap-for-mapped-range (address nbytes)
1442  (let* ((npages (ceiling nbytes *host-page-size*)))
1443    (%stack-block ((vec npages))
1444      (when (eql 0 (#_mincore address nbytes vec))
1445        (let* ((bits (make-array npages :element-type 'bit)))
1446          (dotimes (i npages bits)
1447            (setf (sbit bits i)
1448                  (logand 1 (%get-unsigned-byte vec i)))))))))
1449
1450(defun percentage-of-resident-pages (address nbytes)
1451  (let* ((npages (ceiling nbytes *host-page-size*)))
1452    (%stack-block ((vec npages))
1453      (when (eql 0 (#_mincore address nbytes vec))
1454        (let* ((nresident 0))
1455          (dotimes (i npages (* 100.0 (/ nresident npages)))
1456            (when (logbitp 0 (%get-unsigned-byte vec i))
1457              (incf nresident))))))))
1458
1459(defun mapped-vector-resident-pages (v)
1460  (multiple-value-bind (address nbytes)
1461      (mapped-vector-data-address-and-size v)
1462    (bitmap-for-mapped-range address nbytes)))
1463
1464(defun mapped-vector-resident-pages-percentage (v)
1465  (multiple-value-bind (address nbytes)
1466      (mapped-vector-data-address-and-size v)
1467    (percentage-of-resident-pages address nbytes)))
1468 
1469#+x86-target
1470(progn
1471(defloadvar *last-rdtsc-time* 0)
1472
1473(defstatic *rdtsc-estimated-increment* 1 "Should be positive ...")
1474
1475(defun rdtsc-monotonic ()
1476  "Return monotonically increasing values, partly compensating for
1477   OSes that don't keep the TSCs of all processorsin synch."
1478  (loop
1479    (let* ((old *last-rdtsc-time*)
1480           (new (rdtsc)))
1481      (when (< new old)
1482        ;; We're running on a CPU whose TSC is behind the one
1483        ;; on the last CPU we were scheduled on.
1484        (setq new (+ old *rdtsc-estimated-increment*)))
1485      (when (%store-node-conditional target::symbol.vcell *last-rdtsc-time* old new)
1486        (return new)))))
1487
1488(defun estimate-rdtsc-skew (&optional (niter 1000000))
1489  (do* ((i 0 (1+ i))
1490        (last (rdtsc) next)
1491        (next (rdtsc) (rdtsc))
1492        (skew 1))
1493       ((>= i niter) (setq *rdtsc-estimated-increment* skew))
1494    (declare (fixnum last next skew))
1495    (when (> last next)
1496      (let* ((s (- last next)))
1497        (declare (fixnum s))
1498        (when (> s skew) (setq skew s))))))
1499)
1500
1501
Note: See TracBrowser for help on using the repository browser.