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

Last change on this file since 8241 was 8241, checked in by gb, 12 years ago

Move some macros to before the code that uses them.

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