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

Last change on this file since 7211 was 7211, checked in by palter, 12 years ago

Add support for :element-type to ccl:run-program to allow for binary streams

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