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