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