source: branches/win64/level-1/linux-files.lisp @ 9171

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

Fix #+win64-target version of %stat-values (_stat64, not stat).

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 57.9 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19(eval-when (:compile-toplevel :execute)
20  #+linuxppc-target
21  (require "PPC-LINUX-SYSCALLS")
22  #+linuxx8664-target
23  (require "X8664-LINUX-SYSCALLS")
24  #+darwinppc-target
25  (require "DARWINPPC-SYSCALLS")
26  #+darwinx8664-target
27  (require "DARWINX8664-SYSCALLS")
28  #+(and freebsd-target x8664-target)
29  (require "X8664-FREEBSD-SYSCALLS")
30  )
31
32
33(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
144atomically 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
175atomically 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
213it 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
279OS 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
290environment. 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);
304fails unless the OpenMCL process has super-user privileges or the ID
305given 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);
311fails unless the OpenMCL process has super-user privileges or the ID
312given 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
673by uid. This value comes from the OS user database, not from the $HOME
674environment 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
697system shell (such as sh or tcsh) as a new process, and has that shell
698execute command-line.
699
700If the shell was able to find the command specified in command-line, then
701exit-code is the exit code of that command. If not, it is the exit code
702of 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,
720decrements it by 1. In either case, if the reference count becomes 0,
721close-shared-library frees all memory resources consumed library and causes
722any 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,
748decrements it by 1. In either case, if the reference count becomes 0,
749close-shared-library frees all memory resources consumed library and causes
750any 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
1191not, 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
1198subprocess, 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
1204subprocess, 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
1210subprocess, 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
1216identifies 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,
1222it would only be useful to call this function if the EXTERNAL-PROCESS was
1223created 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
Note: See TracBrowser for help on using the repository browser.