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

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

Clarify %STAT return values, argument constraints in a comment.
%UNIX-FILE-KIND: call NATIVE-TRANSLATED-NAMESTRING on the argument
passed to %STAT.

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