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

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

Milliseconds, %timeval<=.

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