source: branches/working-0710/ccl/level-1/linux-files.lisp @ 7514

Last change on this file since 7514 was 7514, checked in by gb, 14 years ago

Initialize *SPIN-LOCK-TIMEOUTS* to 0 each session.

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