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

Last change on this file since 7611 was 7611, checked in by gb, 13 years ago

Make sure that CCL::PIPE and CCL::FD-OPEN try to force finalization if
they run out of FDs.

Push new entries on the finalization queue via CCL::ATOMIC-PUSH-UVECTOR-CELL.
Defer GC when deleting entries from the finalization queue in
CANCEL-TERMINATE-WHEN-UNREACHABLE.

"canonicalize" the foreign type (:ARRAY :INT 2); using it would make the
code for CCL::PIPE a little clearer, but there are bootstrapping issues.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 49.3 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
643
644
645;;; I believe that the Darwin/FreeBSD syscall infterface is rather ... odd.
646;;; Use libc's interface.
647(defun pipe ()
648  ;;  (rlet ((filedes (:array :int 2)))
649  (%stack-block ((filedes 8))
650    (let* ((status (#_pipe filedes))
651           (errno (if (eql status 0) 0 (%get-errno))))
652      (unless (zerop status)
653        (when (or (eql errno (- #$EMFILE))
654                  (eql errno (- #$ENFILE)))
655          (gc)
656          (drain-termination-queue)
657          (setq status (#_pipe filedes)
658                errno (if (zerop status) 0 (%get-errno)))))
659      (if (zerop status)
660        (values (paref filedes (:array :int)  0) (paref filedes (:array :int)  1))
661        (%errno-disp errno)))))
662
663
664
665(defstruct external-process
666  pid
667  %status
668  %exit-code
669  pty
670  input
671  output
672  error
673  status-hook
674  plist
675  token
676  core
677  args
678  (signal (make-semaphore))
679  (completed (make-semaphore))
680  watched-fd
681  watched-stream
682  )
683
684(defmethod print-object ((p external-process) stream)
685  (print-unreadable-object (p stream :type t :identity t)
686    (let* ((status (external-process-%status p)))
687      (let* ((*print-length* 3))
688        (format stream "~a" (external-process-args p)))
689      (format stream "[~d] (~a" (external-process-pid p) status)
690      (unless (eq status :running)
691        (format stream " : ~d" (external-process-%exit-code p)))
692      (format stream ")"))))
693
694(defun get-descriptor-for (object proc close-in-parent close-on-error
695                                  &rest keys &key direction (element-type 'character)
696                                  &allow-other-keys)
697  (etypecase object
698    ((eql t)
699     (values nil nil close-in-parent close-on-error))
700    (null
701     (let* ((fd (fd-open "/dev/null" (case direction
702                                       (:input #$O_RDONLY)
703                                       (:output #$O_WRONLY)
704                                       (t #$O_RDWR)))))
705       (if (< fd 0)
706         (signal-file-error fd "/dev/null"))
707       (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
708    ((eql :stream)
709     (multiple-value-bind (read-pipe write-pipe) (pipe)
710       (case direction
711         (:input
712          (values read-pipe
713                  (make-fd-stream write-pipe
714                                  :direction :output
715                                  :element-type element-type
716                                  :interactive nil
717                                  :basic t
718                                  :auto-close t)
719                  (cons read-pipe close-in-parent)
720                  (cons write-pipe close-on-error)))
721         (:output
722          (values write-pipe
723                  (make-fd-stream read-pipe
724                                  :direction :input
725                                  :element-type element-type
726                                  :interactive nil
727                                  :basic t
728                                  :auto-close t)
729                  (cons write-pipe close-in-parent)
730                  (cons read-pipe close-on-error)))
731         (t
732          (fd-close read-pipe)
733          (fd-close write-pipe)
734          (report-bad-arg direction '(member :input :output))))))
735    ((or pathname string)
736     (with-open-stream (file (apply #'open object keys))
737       (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)))))
738         (values fd
739                 nil
740                 (cons fd close-in-parent)
741                 (cons fd close-on-error)))))
742    (fd-stream
743     (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
744       (values fd
745               nil
746               (cons fd close-in-parent)
747               (cons fd close-on-error))))
748    (stream
749     (ecase direction
750       (:input
751        (with-cstrs ((template "lisp-tempXXXXXX"))
752          (let* ((fd (#_mkstemp template)))
753            (if (< fd 0)
754              (%errno-disp fd))
755            (#_unlink template)
756            (loop
757              (multiple-value-bind (line no-newline)
758                  (read-line object nil nil)
759                (unless line
760                  (return))
761                (let* ((len (length line)))
762                  (%stack-block ((buf (1+ len)))
763                    (%cstr-pointer line buf)
764                    (fd-write fd buf len)
765                    (if no-newline
766                      (return))
767                    (setf (%get-byte buf) (char-code #\newline))
768                    (fd-write fd buf 1)))))
769            (fd-lseek fd 0 #$SEEK_SET)
770            (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))))
771       (:output
772        (multiple-value-bind (read-pipe write-pipe) (pipe)
773          (setf (external-process-watched-fd proc) read-pipe
774                (external-process-watched-stream proc) object)
775          (incf (car (external-process-token proc)))
776          (values write-pipe
777                  nil
778                  (cons write-pipe close-in-parent)
779                  (cons read-pipe close-on-error))))))))
780
781(let* ((external-processes ())
782       (external-processes-lock (make-lock)))
783  (defun add-external-process (p)
784    (with-lock-grabbed (external-processes-lock)
785      (push p external-processes)))
786  (defun remove-external-process (p)
787    (with-lock-grabbed (external-processes-lock)
788      (setq external-processes (delete p external-processes))))
789  ;; Likewise
790  (defun external-processes ()
791    (with-lock-grabbed (external-processes-lock)
792      (copy-list external-processes)))
793  )
794
795
796
797(defun monitor-external-process (p)
798  (let* ((in-fd (external-process-watched-fd p))
799         (out-stream (external-process-watched-stream p))
800         (token (external-process-token p))
801         (terminated))
802    (loop
803      (when (and terminated (null in-fd))
804        (signal-semaphore (external-process-completed p))
805        (return))
806      (if in-fd
807        (when (fd-input-available-p in-fd *ticks-per-second*)
808          (%stack-block ((buf 1024))
809            (let* ((n (fd-read in-fd buf 1024)))
810              (declare (fixnum n))
811              (if (<= n 0)
812                (progn
813                  (without-interrupts
814                   (decf (car token))
815                   (fd-close in-fd)
816                   (setq in-fd nil)))
817                (let* ((string (make-string 1024)))
818                  (declare (dynamic-extent string))
819                  (%str-from-ptr buf n string)
820                  (write-sequence string out-stream :end n)))))))
821      (let* ((statusflags (check-pid (external-process-pid p)
822                                     (logior
823                                      (if in-fd #$WNOHANG 0)
824                                      #$WUNTRACED)))
825             (oldstatus (external-process-%status p)))
826        (cond ((null statusflags)
827               (remove-external-process p)
828               (setq terminated t))
829              ((eq statusflags t))      ; Running.
830              (t
831               (multiple-value-bind (status code core)
832                   (cond ((wifstopped statusflags)
833                          (values :stopped (wstopsig statusflags)))
834                         ((wifexited statusflags)
835                          (values :exited (wexitstatus statusflags)))
836                         (t
837                          (let* ((signal (wtermsig statusflags)))
838                            (declare (fixnum signal))
839                            (values
840                             (if (or (= signal #$SIGSTOP)
841                                     (= signal #$SIGTSTP)
842                                     (= signal #$SIGTTIN)
843                                     (= signal #$SIGTTOU))
844                               :stopped
845                               :signaled)
846                             signal
847                             (logtest #$WCOREFLAG statusflags)))))
848                 (setf (external-process-%status p) status
849                       (external-process-%exit-code p) code
850                       (external-process-core p) core)
851                 (let* ((status-hook (external-process-status-hook p)))
852                   (when (and status-hook (not (eq oldstatus status)))
853                     (funcall status-hook p)))
854                 (when (or (eq status :exited)
855                           (eq status :signaled))
856                   (remove-external-process p)
857                   (setq terminated t)))))))))
858     
859(defun run-external-process (proc in-fd out-fd error-fd &optional env)
860  ;; type-check the env variable
861  (dolist (pair env)
862    (destructuring-bind (var . val) pair
863      (assert (typep var '(or string symbol character)))
864      (assert (typep val 'string)))) 
865  (call-with-string-vector
866   #'(lambda (argv)
867       (let* ((child-pid (#_fork)))
868         (declare (fixnum child-pid))
869         (cond ((zerop child-pid)
870                ;; Running in the child; do an exec
871                (dolist (pair env)
872                  (setenv (string (car pair)) (cdr pair)))
873                (without-interrupts
874                 (exec-with-io-redirection
875                  in-fd out-fd error-fd argv)))
876               ((> child-pid 0)
877                ;; Running in the parent: success
878                (setf (external-process-pid proc) child-pid)
879                (add-external-process proc)
880                (signal-semaphore (external-process-signal proc))
881                (monitor-external-process proc)))))
882   (external-process-args proc)))
883
884               
885(defun run-program (program args &key
886                            (wait t) pty
887                            input if-input-does-not-exist
888                            output (if-output-exists :error)
889                            (error :output) (if-error-exists :error)
890                            status-hook (element-type 'character)
891                            env)
892  "Invoke an external program as an OS subprocess of lisp."
893  (declare (ignore pty))
894  (unless (every #'(lambda (a) (typep a 'simple-string)) args)
895    (error "Program args must all be simple strings : ~s" args))
896  (push (native-untranslated-namestring program) args)
897  (let* ((token (list 0))
898         (in-fd nil)
899         (in-stream nil)
900         (out-fd nil)
901         (out-stream nil)
902         (error-fd nil)
903         (error-stream nil)
904         (close-in-parent nil)
905         (close-on-error nil)
906         (proc
907          (make-external-process
908           :pid nil
909           :args args
910           :%status :running
911           :input nil
912           :output nil
913           :error nil
914           :token token
915           :status-hook status-hook)))
916    (unwind-protect
917         (progn
918           (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
919             (get-descriptor-for input proc  nil nil :direction :input
920                                 :if-does-not-exist if-input-does-not-exist
921                                 :element-type element-type))
922           (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
923             (get-descriptor-for output proc close-in-parent close-on-error
924                                 :direction :output
925                                 :if-exists if-output-exists
926                                 :element-type element-type))
927           (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
928             (if (eq error :output)
929               (values out-fd out-stream close-in-parent close-on-error)
930               (get-descriptor-for error proc close-in-parent close-on-error
931                                   :direction :output
932                                   :if-exists if-error-exists
933                                   :element-type element-type)))
934           (setf (external-process-input proc) in-stream
935                 (external-process-output proc) out-stream
936                 (external-process-error proc) error-stream)
937           (process-run-function
938            (format nil "Monitor thread for external process ~a" args)
939                   
940            #'run-external-process proc in-fd out-fd error-fd env)
941           (wait-on-semaphore (external-process-signal proc))
942           )
943      (dolist (fd close-in-parent) (fd-close fd))
944      (unless (external-process-pid proc)
945        (dolist (fd close-on-error) (fd-close fd)))
946      (when (and wait (external-process-pid proc))
947        (with-interrupts-enabled
948            (wait-on-semaphore (external-process-completed proc)))))
949    (and (external-process-pid proc) proc)))
950
951
952(defmacro wtermsig (status)
953  `(ldb (byte 7 0) ,status))
954
955(defmacro wexitstatus (status)
956  `(ldb (byte 8 8) (the fixnum ,status)))
957
958(defmacro wstopsig (status)
959  `(wexitstatus ,status))
960
961(defmacro wifexited (status)
962  `(eql (wtermsig ,status) 0))
963
964(defmacro wifstopped (status)
965  `(eql #x7f (ldb (byte 7 0) (the fixnum ,status))))
966
967(defmacro wifsignaled (status)
968  (let* ((statname (gensym)))
969    `(let* ((,statname ,status))
970      (and (not (wifstopped ,statname)) (not (wifexited ,statname))))))
971
972
973(defun check-pid (pid &optional (flags (logior  #$WNOHANG #$WUNTRACED)))
974  (declare (fixnum pid))
975  (rlet ((status :signed))
976    (let* ((retval (#_waitpid pid status flags)))
977      (declare (fixnum retval))
978      (if (= retval pid)
979        (pref status :signed)
980        (zerop retval)))))
981
982
983
984
985
986(defun external-process-wait (proc &optional check-stopped)
987  (process-wait "external-process-wait"
988                #'(lambda ()
989                    (case (external-process-%status proc)
990                      (:running)
991                      (:stopped
992                       (when check-stopped
993                         t))
994                      (t
995                       (when (zerop (car (external-process-token proc)))
996                         t))))))
997
998(defun external-process-status (proc)
999  "Return information about whether an OS subprocess is running; or, if
1000not, why not; and what its result code was if it completed."
1001  (require-type proc 'external-process)
1002  (values (external-process-%status proc)
1003          (external-process-%exit-code proc)))
1004
1005(defun external-process-input-stream (proc)
1006  "Return the lisp stream which is used to write input to a given OS
1007subprocess, if it has one."
1008  (require-type proc 'external-process)
1009  (external-process-input proc))
1010
1011(defun external-process-output-stream (proc)
1012  "Return the lisp stream which is used to read output from a given OS
1013subprocess, if there is one."
1014  (require-type proc 'external-process)
1015  (external-process-output proc))
1016
1017(defun external-process-error-stream (proc)
1018  "Return the stream which is used to read error output from a given OS
1019subprocess, if it has one."
1020  (require-type proc 'external-process)
1021  (external-process-error proc))
1022
1023(defun external-process-id (proc)
1024  "Return the process id of an OS subprocess, a positive integer which
1025identifies it."
1026  (require-type proc 'external-process)
1027  (external-process-pid proc))
1028 
1029(defun signal-external-process (proc signal)
1030  "Send the specified signal to the specified external process.  (Typically,
1031it would only be useful to call this function if the EXTERNAL-PROCESS was
1032created with :WAIT NIL.) Return T if successful; signal an error otherwise."
1033  (require-type proc 'external-process)
1034  (let* ((pid (external-process-pid proc))
1035         (error (syscall syscalls::kill pid signal)))
1036    (or (eql error 0)
1037        (%errno-disp error))))
1038
1039;;; EOF on a TTY is transient, but I'm less sure of other cases.
1040(defun eof-transient-p (fd)
1041  (case (%unix-fd-kind fd)
1042    (:tty t)
1043    (t nil)))
1044
1045
1046(defstruct (shared-resource (:constructor make-shared-resource (name)))
1047  (name)
1048  (lock (make-lock))
1049  (primary-owner *current-process*)
1050  (primary-owner-notify (make-semaphore))
1051  (current-owner nil)
1052  (requestors (make-dll-header)))
1053
1054(defstruct (shared-resource-request
1055             (:constructor make-shared-resource-request (process))
1056             (:include dll-node))
1057  process
1058  (signal (make-semaphore)))
1059             
1060
1061;; Returns NIL if already owned by calling thread, T otherwise
1062(defun %acquire-shared-resource (resource  &optional verbose)
1063  (let* ((current *current-process*))
1064    (with-lock-grabbed ((shared-resource-lock resource))
1065      (let* ((secondary (shared-resource-current-owner resource)))
1066        (if (or (eq current secondary)
1067                (and (null secondary)
1068                     (eq current (shared-resource-primary-owner resource))))
1069          (return-from %acquire-shared-resource nil))))
1070    (let* ((request (make-shared-resource-request *current-process*)))
1071      (when verbose
1072        (format t "~%~%;;;~%;;; ~a requires access to ~a~%;;;~%~%"
1073                *current-process* (shared-resource-name resource)))
1074      (with-lock-grabbed ((shared-resource-lock resource))
1075        (append-dll-node request (shared-resource-requestors resource)))
1076      (wait-on-semaphore (shared-resource-request-signal request))
1077      (assert (eq current (shared-resource-current-owner resource)))
1078      (when verbose
1079        (format t "~%~%;;;~%;;; ~a is now owned by ~a~%;;;~%~%"
1080                (shared-resource-name resource) current))
1081      t)))
1082
1083;;; If we're the primary owner and there is no secondary owner, do nothing.
1084;;; If we're the secondary owner, cease being the secondary owner.
1085(defun %release-shared-resource (r)
1086  (let* ((not-any-owner ()))
1087    (with-lock-grabbed ((shared-resource-lock r))
1088      (let* ((current *current-process*)
1089             (primary (shared-resource-primary-owner r))
1090             (secondary (shared-resource-current-owner r)))
1091        (unless (setq not-any-owner
1092                      (not (or (eq current secondary)
1093                               (and (null secondary)
1094                                    (eq current primary)))))
1095          (when (eq current secondary)
1096            (setf (shared-resource-current-owner r) nil)
1097            (signal-semaphore (shared-resource-primary-owner-notify r))))))
1098    (when not-any-owner
1099      (signal-program-error "Process ~a does not own ~a" *current-process*
1100                            (shared-resource-name r)))))
1101
1102;;; The current thread should be the primary owner; there should be
1103;;; no secondary owner.  Wakeup the specified (or first) requesting
1104;;; process, then block on our semaphore
1105(defun %yield-shared-resource (r &optional to)
1106  (let* ((request nil))
1107    (with-lock-grabbed ((shared-resource-lock r))
1108      (let* ((current *current-process*)
1109             (primary (shared-resource-primary-owner r)))
1110        (when (and (eq current primary)
1111                   (null (shared-resource-current-owner r)))
1112          (setq request
1113                (let* ((header (shared-resource-requestors r)))
1114                  (if to 
1115                    (do-dll-nodes (node header)
1116                      (when (eq to (shared-resource-request-process node))
1117                        (return node)))
1118                    (let* ((first (dll-header-first header)))
1119                      (unless (eq first header)
1120                        first)))))
1121          (when request
1122            (remove-dll-node request)
1123            (setf (shared-resource-current-owner r)
1124                  (shared-resource-request-process request))
1125            (signal-semaphore (shared-resource-request-signal request))))))
1126    (when request
1127      (wait-on-semaphore (shared-resource-primary-owner-notify r))
1128      (format t "~%;;;~%;;;control of ~a restored to ~a~%;;;~&"
1129              (shared-resource-name r)
1130              *current-process*))))
1131
1132
1133     
1134
1135(defun %shared-resource-requestor-p (r proc)
1136  (with-lock-grabbed ((shared-resource-lock r))
1137    (do-dll-nodes (node (shared-resource-requestors r))
1138      (when (eq proc (shared-resource-request-process node))
1139        (return t)))))
1140
1141(defparameter *resident-editor-hook* nil
1142  "If non-NIL, should be a function that takes an optional argument
1143   (like ED) and invokes a \"resident\" editor.")
1144
1145(defun ed (&optional arg)
1146  (if *resident-editor-hook*
1147    (funcall *resident-editor-hook* arg)
1148    (error "This implementation doesn't provide a resident editor.")))
1149
1150(defun running-under-emacs-p ()
1151  (not (null (getenv "EMACS"))))
1152
1153(defloadvar *cpu-count* nil)
1154
1155(defun cpu-count ()
1156  (or *cpu-count*
1157      (setq *cpu-count*
1158            #+darwin-target
1159            (rlet ((info :host_basic_info)
1160                   (count :mach_msg_type_number_t #$HOST_BASIC_INFO_COUNT))
1161              (if (eql #$KERN_SUCCESS (#_host_info (#_mach_host_self)
1162                                                   #$HOST_BASIC_INFO
1163                                                   info
1164                                                   count))
1165                (pref info :host_basic_info.max_cpus)
1166                1))
1167            #+linux-target
1168            (or
1169             (let* ((n (#_sysconf #$_SC_NPROCESSORS_ONLN)))
1170               (declare (fixnum n))
1171               (if (> n 0) n))
1172             (ignore-errors
1173               (with-open-file (p "/proc/cpuinfo")
1174                 (let* ((ncpu 0)
1175                        (match "processor")
1176                        (matchlen (length match)))
1177                   (do* ((line (read-line p nil nil) (read-line p nil nil)))
1178                        ((null line) ncpu)
1179                     (let* ((line-length (length line)))
1180                       (when (and
1181                              (> line-length matchlen)
1182                              (string= match line
1183                                       :end2 matchlen)
1184                              (whitespacep (schar line matchlen)))
1185                         (incf ncpu)))))))
1186             1)
1187            #+freebsd-target
1188            (rlet ((ret :uint))
1189              (%stack-block ((mib (* (record-length :uint) 2)))
1190              (setf (paref mib (:array :uint) 0)
1191                    #$CTL_HW
1192                    (paref mib (:array :uint) 1)
1193                    #$HW_NCPU)
1194              (rlet ((oldsize :uint (record-length :uint)))
1195                (if (eql 0 (#_sysctl mib 2 ret oldsize (%null-ptr) 0))
1196                  (pref ret :uint)
1197                  1))))
1198            )))
1199
1200(def-load-pointers spin-count ()
1201  (if (eql 1 (cpu-count))
1202    (%defglobal '*spin-lock-tries* 1)
1203    (%defglobal '*spin-lock-tries* 1024))
1204  (%defglobal '*spin-lock-timeouts* 0))
1205
1206(defun yield ()
1207  (#_sched_yield))
1208
1209(defloadvar *host-page-size* (#_getpagesize))
1210
1211;;(assert (= (logcount *host-page-size*) 1))
1212
1213(defun map-file-to-ivector (pathname element-type)
1214  (let* ((upgraded-type (upgraded-array-element-type element-type))
1215         (upgraded-ctype (specifier-type upgraded-type)))
1216    (unless (and (typep upgraded-ctype 'numeric-ctype)
1217                 (eq 'integer (numeric-ctype-class upgraded-ctype)))
1218      (error "Invalid element-type: ~s" element-type))
1219    (let* ((bits-per-element (integer-length (- (numeric-ctype-high upgraded-ctype)
1220                                                (numeric-ctype-low upgraded-ctype))))
1221           (fd (fd-open (native-translated-namestring pathname) #$O_RDONLY)))
1222      (if (< fd 0)
1223        (signal-file-error fd pathname)
1224        (let* ((len (fd-size fd)))
1225          (if (< len 0)
1226            (signal-file-error fd pathname)
1227            (let* ((nbytes (+ *host-page-size*
1228                              (logandc2 (+ len
1229                                           (1- *host-page-size*))
1230                                        (1- *host-page-size*))))
1231
1232                   (ndata-elements
1233                    (ash len
1234                         (ecase bits-per-element
1235                           (1 3)
1236                           (8 0)
1237                           (16 -1)
1238                           (32 -2)
1239                           (64 -3))))
1240                   (nalignment-elements
1241                    (ash target::nbits-in-word
1242                         (ecase bits-per-element
1243                           (1 0)
1244                           (8 -3)
1245                           (16 -4)
1246                           (32 -5)
1247                           (64 -6)))))
1248              (if (>= (+ ndata-elements nalignment-elements)
1249                      array-total-size-limit)
1250                (progn
1251                  (fd-close fd)
1252                  (error "Can't make a vector with ~s elements in this implementation." (+ ndata-elements nalignment-elements)))
1253                (let* ((addr (#_mmap +null-ptr+
1254                                     nbytes
1255                                     #$PROT_NONE
1256                                     (logior #$MAP_ANON #$MAP_PRIVATE)
1257                                     -1
1258                                     0)))             
1259                  (if (eql addr (%int-to-ptr (1- (ash 1 target::nbits-in-word)))) ; #$MAP_FAILED
1260                    (let* ((errno (%get-errno)))
1261                      (fd-close fd)
1262                      (error "Can't map ~d bytes: ~a" nbytes (%strerror errno)))
1263              ;;; Remap the first page so that we can put a vector header
1264              ;;; there; use the first word on the first page to remember
1265              ;;; the file descriptor.
1266                    (progn
1267                      (#_mmap addr
1268                              *host-page-size*
1269                              (logior #$PROT_READ #$PROT_WRITE)
1270                              (logior #$MAP_ANON #$MAP_PRIVATE #$MAP_FIXED)
1271                              -1
1272                              0)
1273                      (setf (pref addr :int) fd)
1274                      (let* ((header-addr (%inc-ptr addr (- *host-page-size*
1275                                                            (* 2 target::node-size)))))
1276                        (setf (pref header-addr :unsigned-long)
1277                              (logior (element-type-subtype upgraded-type)
1278                                      (ash (+ ndata-elements nalignment-elements) target::num-subtag-bits)))
1279                        (when (> len 0)
1280                          (let* ((target-addr (%inc-ptr header-addr (* 2 target::node-size))))
1281                            (unless (eql target-addr
1282                                         (#_mmap target-addr
1283                                                 len
1284                                                 #$PROT_READ
1285                                                 (logior #$MAP_PRIVATE #$MAP_FIXED)
1286                                                 fd
1287                                                 0))
1288                              (let* ((errno (%get-errno)))
1289                                (fd-close fd)
1290                                (#_munmap addr nbytes)
1291                                (error "Mapping failed: ~a" (%strerror errno))))))
1292                        (with-macptrs ((v (%inc-ptr header-addr target::fulltag-misc)))
1293                          (let* ((vector (rlet ((p :address v)) (%get-object p 0))))
1294                            ;; Tell some parts of OpenMCL - notably the
1295                            ;; printer - that this thing off in foreign
1296                            ;; memory is a real lisp object and not
1297                            ;; "bogus".
1298                            (with-lock-grabbed (*heap-ivector-lock*)
1299                              (push vector *heap-ivectors*))
1300                            (make-array ndata-elements
1301                                        :element-type upgraded-type
1302                                        :displaced-to vector
1303                                        :adjustable t
1304                                        :displaced-index-offset nalignment-elements)))))))))))))))
1305
1306(defun map-file-to-octet-vector (pathname)
1307  (map-file-to-ivector pathname '(unsigned-byte 8)))
1308
1309(defun mapped-vector-data-address-and-size (displaced-vector)
1310  (let* ((v (array-displacement displaced-vector))
1311         (element-type (array-element-type displaced-vector)))
1312    (if (or (eq v displaced-vector)
1313            (not (with-lock-grabbed (*heap-ivector-lock*)
1314                   (member v *heap-ivectors*))))
1315      (error "~s doesn't seem to have been allocated via ~s and not yet unmapped" displaced-vector 'map-file-to-ivector))
1316    (let* ((pv (rlet ((x :address)) (%set-object x 0 v) (pref x :address)))
1317           (ctype (specifier-type element-type))
1318           (arch (backend-target-arch *target-backend*)))
1319      (values (%inc-ptr pv (- (* 2 target::node-size) target::fulltag-misc))
1320              (- (funcall (arch::target-array-data-size-function arch)
1321                          (ctype-subtype ctype)
1322                          (length v))
1323                 target::node-size)))))
1324
1325 
1326;;; Argument should be something returned by MAP-FILE-TO-IVECTOR;
1327;;; this should be called at most once for any such object.
1328(defun unmap-ivector (displaced-vector)
1329  (multiple-value-bind (data-address size-in-octets)
1330      (mapped-vector-data-address-and-size displaced-vector)
1331  (let* ((v (array-displacement displaced-vector))
1332         (base-address (%inc-ptr data-address (- *host-page-size*)))
1333         (fd (pref base-address :int)))
1334      (let* ((element-type (array-element-type displaced-vector)))
1335        (adjust-array displaced-vector 0
1336                      :element-type element-type
1337                      :displaced-to (make-array 0 :element-type element-type)
1338                      :displaced-index-offset 0))
1339      (with-lock-grabbed (*heap-ivector-lock*)
1340        (setq *heap-ivectors* (delete v *heap-ivectors*)))
1341      (#_munmap base-address (+ size-in-octets *host-page-size*))     
1342      (fd-close fd)
1343      t)))
1344
1345(defun unmap-octet-vector (v)
1346  (unmap-ivector v))
1347
1348(defun lock-mapped-vector (v)
1349  (multiple-value-bind (address nbytes)
1350      (mapped-vector-data-address-and-size v)
1351    (eql 0 (#_mlock address nbytes))))
1352
1353(defun unlock-mapped-vector (v)
1354  (multiple-value-bind (address nbytes)
1355      (mapped-vector-data-address-and-size v)
1356    (eql 0 (#_munlock address nbytes))))
1357
1358(defun bitmap-for-mapped-range (address nbytes)
1359  (let* ((npages (ceiling nbytes *host-page-size*)))
1360    (%stack-block ((vec npages))
1361      (when (eql 0 (#_mincore address nbytes vec))
1362        (let* ((bits (make-array npages :element-type 'bit)))
1363          (dotimes (i npages bits)
1364            (setf (sbit bits i)
1365                  (logand 1 (%get-unsigned-byte vec i)))))))))
1366
1367(defun percentage-of-resident-pages (address nbytes)
1368  (let* ((npages (ceiling nbytes *host-page-size*)))
1369    (%stack-block ((vec npages))
1370      (when (eql 0 (#_mincore address nbytes vec))
1371        (let* ((nresident 0))
1372          (dotimes (i npages (* 100.0 (/ nresident npages)))
1373            (when (logbitp 0 (%get-unsigned-byte vec i))
1374              (incf nresident))))))))
1375
1376(defun mapped-vector-resident-pages (v)
1377  (multiple-value-bind (address nbytes)
1378      (mapped-vector-data-address-and-size v)
1379    (bitmap-for-mapped-range address nbytes)))
1380
1381(defun mapped-vector-resident-pages-percentage (v)
1382  (multiple-value-bind (address nbytes)
1383      (mapped-vector-data-address-and-size v)
1384    (percentage-of-resident-pages address nbytes)))
1385 
Note: See TracBrowser for help on using the repository browser.