Changeset 10637


Ignore:
Timestamp:
Sep 8, 2008, 5:58:30 AM (11 years ago)
Author:
gb
Message:

Don't use syscall interfaces (in the many places that we did).
(Remaining cases are actually windows-specific, where we use
"syscall" to reach code in the lisp kernel.)
Conditionalize for Windows in other ways, too.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/linux-files.lisp

    r10517 r10637  
    1717(in-package "CCL")
    1818
     19(defconstant unix-to-universal-time 2208988800)
     20
     21#+windows-target
     22(progn
     23
     24(defun strip-drive-for-now (string)
     25  string
     26  #+no
     27  (or (and (> (length string) 2)
     28           (eql (schar string 1) #\:)
     29           (let* ((copy (subseq string 0)))
     30             (setf (schar copy 0) (char-downcase (schar copy 0)))
     31             (setf (schar copy  1) #\|)
     32             copy))
     33      string))
     34           
     35
     36(defun nbackslash-to-forward-slash (namestring)
     37  (dotimes (i (length namestring) namestring)
     38    (when (eql (schar namestring i) #\\)
     39      (setf (schar namestring i) #\/))))
     40
     41(defconstant univeral-time-start-in-windows-seconds 9435484800)
     42
     43(defun windows-filetime-to-universal-time (ft)
     44  (let* ((100-ns (dpb (pref ft #>FILETIME.dwHighDateTime) (byte 32 32)
     45                      (pref ft #>FILETIME.dwLowDateTime)))
     46         (seconds-since-windows-epoch (floor 100-ns 10000000)))
     47    (- seconds-since-windows-epoch univeral-time-start-in-windows-seconds)))
     48)
    1949
    2050(defun get-foreign-namestring (pointer)
     
    2555  #+darwin-target
    2656  (precompose-simple-string (%get-utf-8-cstring pointer))
     57  #+windows-target (strip-drive-for-now
     58                    (nbackslash-to-forward-slash
     59                     (%get-native-utf-16-cstring pointer)))
    2760  ;; On some other platforms, the namestring is assumed to
    2861  ;; be encoded according to the current locale's character
    2962  ;; encoding (though FreeBSD seems to be moving towards
    3063  ;; precomposed UTF-8.).
    31   ;; In any case, the use if %GET-CSTRING here is wrong ...
    32   #-darwin-target
     64  ;; In any case, the use of %GET-CSTRING here is wrong ...
     65  #-(or darwin-target windows-target)
    3366  (%get-cstring pointer))
    3467
     
    144177  (%signal-semaphore-ptr (semaphore-value s)))
    145178
    146 (defun %os-getcwd (buf bufsize)
     179(defun %os-getcwd (buf noctets)
    147180  ;; Return N < 0, if error
    148   ;;        N < bufsize: success, string is of length n
    149   ;;        N > bufsize: buffer needs to be larger.
    150   (let* ((p (#_getcwd buf bufsize)))
     181  ;;        N < noctets: success, string is of length N (octets).
     182  ;;        N >= noctets: buffer needs to be larger.
     183  (let* ((p #+windows-target
     184           (#__wgetcwd buf (ash noctets -1))
     185           #-windows-target
     186           (#_getcwd buf noctets)))
    151187    (declare (dynamic-extent p))
    152188    (if (%null-ptr-p p)
    153189      (let* ((err (%get-errno)))
    154190        (if (eql err (- #$ERANGE))
    155           (+ bufsize bufsize)
     191          (+ noctets noctets)
    156192          err))
    157       (dotimes (i bufsize (+ bufsize bufsize))
     193      #+windows-target
     194      (do* ((i 0 (+ i 2)))
     195           ((= i noctets) (+ noctets noctets))
     196        (when (eql (%get-unsigned-word buf i) 0)
     197          (return i)))
     198      #-windows-target
     199      (dotimes (i noctets (+ noctets noctets))
    158200        (when (eql 0 (%get-byte buf i))
    159201          (return i))))))
     
    166208           (%stack-block ((buf bufsize))
    167209             (let* ((len (%os-getcwd buf bufsize)))
    168                (cond ((< len 0) (%errno-disp len bufsize))
     210               (cond ((< len 0) (%errno-disp len))
    169211                     ((< len bufsize)
    170                       (setf (%get-unsigned-byte buf len) 0)
    171212                      (values (get-foreign-namestring buf) len))
    172213                     (t (values nil len)))))))
    173214    (do* ((string nil)
    174           (len 64)
     215          (len #+windows-target 128 #-windows-target 64)
    175216          (bufsize len len))
    176217         ((multiple-value-setq (string len) (try-getting-dirname bufsize))
     
    189230
    190231(defmacro with-filename-cstrs (&rest rest)
    191   `(#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ,@rest))
     232  `(#+darwin-target with-utf-8-cstrs
     233    #+windows-target with-native-utf-16-cstrs
     234    #-(or darwin-target windows-target) with-cstrs ,@rest))
     235
    192236
    193237(defun %chdir (dirname)
    194238  (with-filename-cstrs ((dirname dirname))
    195     (int-errno-call (#_chdir dirname))))
     239    (int-errno-call (#+windows-target #__wchdir #-windows-target #_chdir dirname))))
    196240
    197241(defun %mkdir (name mode)
     242  #+windows-target (declare (ignore mode))
    198243  (let* ((name name)
    199244         (len (length name)))
     
    201246      (setq name (subseq name 0 (1- len))))
    202247    (with-filename-cstrs ((name name))
    203       (int-errno-call (#_mkdir name mode)))))
     248      (int-errno-call (#+windows-target #__wmkdir #-windows-target #_mkdir  name #-windows-target mode)))))
    204249
    205250(defun %rmdir (name)
     
    209254                 (eql (%get-byte name last) (char-code #\/)))
    210255        (setf (%get-byte name last) 0))
    211       (int-errno-call (#_rmdir name)))))
     256      (int-errno-call (#+windows-target #__wrmdir #-windows-target #_rmdir name)))))
    212257
    213258
     
    226271  "Set the value of the environment variable named by name, in the OS
    227272environment. If there is no such environment variable, create it."
     273  #+windows-target (declare (ignore overwrite))
     274  #-windows-target
    228275  (with-cstrs ((ckey key)
    229276               (cvalue value))
    230     (#_setenv ckey cvalue (if overwrite 1 0))))
    231 
     277    (#_setenv ckey cvalue (if overwrite 1 0)))
     278  #+windows-target
     279  (with-cstrs ((pair (format nil "~a=~a" key value)))
     280    (#__putenv pair))
     281  )
     282
     283#-windows-target                        ; Windows "impersonation" crap ?
    232284(defun setuid (uid)
    233285  "Attempt to change the current user ID (both real and effective);
     
    236288  (int-errno-call (#_setuid uid)))
    237289
     290#-windows-target
    238291(defun setgid (uid)
    239292  "Attempt to change the current group ID (both real and effective);
     
    247300;;; they're talking about.
    248301
     302#-windows-target
    249303(defun %stat-values (result stat)
    250304  (if (eql 0 (the fixnum result))
     
    267321      (values nil nil nil nil nil nil nil)))
    268322
     323#+win64-target
     324(defun %stat-values (result stat)
     325  (if (eql 0 (the fixnum result))
     326      (values
     327       t
     328       (pref stat :_stat64.st_mode)
     329       (pref stat :_stat64.st_size)
     330       (pref stat :_stat64.st_mtime)
     331       (pref stat :_stat64.st_ino)
     332       (pref stat :_stat64.st_uid)
     333       #$BUFSIZ
     334       (pref stat :_stat64.st_mtime)     ; ???
     335       (pref stat :_stat64.st_gid))
     336      (values nil nil nil nil nil nil nil nil nil)))
     337
     338#+windows-target
     339(defun windows-strip-trailing-slash (namestring)
     340  (do* ((len (length namestring) (length namestring)))
     341       ((<= len 3) namestring)
     342    (let* ((p (1- len))
     343           (ch (char namestring p)))
     344      (unless (or (eql ch #\\)
     345                  (eql ch #\/))
     346        (return namestring))
     347      (setq namestring (subseq namestring 0 p)))))
     348
    269349
    270350(defun %%stat (name stat)
    271   (with-filename-cstrs ((cname name))
     351  (with-filename-cstrs ((cname #+windows-target (windows-strip-trailing-slash name) #-windows-target name))
    272352    (%stat-values
    273353     #+linux-target
    274354     (#_ __xstat #$_STAT_VER_LINUX cname stat)
    275355     #-linux-target
    276      (#_stat cname stat)
     356     (int-errno-call (#+windows-target #__wstat64 #-windows-target #_stat cname stat))
    277357     stat)))
    278358
     
    282362   (#_ __fxstat #$_STAT_VER_LINUX fd stat)
    283363   #-linux-target
    284    (#_fstat fd stat)
     364   (int-errno-call (#+windows-target #__fstat64 #-windows-target #_fstat fd stat))
    285365   stat))
    286366
     367#-windows-target
    287368(defun %%lstat (name stat)
    288369  (with-filename-cstrs ((cname name))
     
    299380;;; NAME should be a "native namestring", e.g,, have all lisp pathname
    300381;;; escaping removed.
     382#-windows-target
    301383(defun %stat (name &optional link-p)
    302384  (rlet ((stat :stat))
     
    305387      (%%stat name stat))))
    306388
     389#+windows-target
     390(defun %stat (name &optional link-p)
     391  (declare (ignore link-p))
     392  (rlet ((stat  #+win64-target #>_stat64))
     393    (%%stat name stat)))
     394
    307395(defun %fstat (fd)
    308   (rlet ((stat :stat))
     396  (rlet ((stat #+win64-target #>_stat64 #-win64-target :stat))
    309397    (%%fstat fd stat)))
    310398
     
    315403      (cond ((eql kind #$S_IFDIR) :directory)
    316404            ((eql kind #$S_IFREG) :file)
     405            #-windows-target
    317406            ((eql kind #$S_IFLNK) :link)
    318407            ((eql kind #$S_IFIFO) :pipe)
     408            #-windows-target
    319409            ((eql kind #$S_IFSOCK) :socket)
    320410            ((eql kind #$S_IFCHR) :character-special)
     
    329419    (%file-kind (nth-value 1 (%fstat fd)))))
    330420
     421#-windows-target
    331422(defun %uts-string (result idx buf)
    332423  (if (>= result 0)
     
    386477    (%uts-string (#_uname buf) idx buf)))
    387478
     479#-windows-target
    388480(defun fd-dup (fd)
    389481  (int-errno-call (#_dup fd)))
    390482
     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
    391499(defun fd-fsync (fd)
     500  #+windows-target (progn fd 0)
     501  #-windows-target
    392502  (int-errno-call (#_fsync fd)))
    393503
     504#-windows-target
     505(progn
    394506(defun fd-get-flags (fd)
    395507  (int-errno-call (#_fcntl fd #$F_GETFL)))
     
    409521      old
    410522      (fd-set-flags fd (logandc2 old mask)))))
    411 
     523)
    412524
    413525;;; Assume that any quoting's been removed already.
     
    426538          (concatenate 'string (get-user-home-dir uid) (if slash-pos (subseq namestring slash-pos) "/")))))))
    427539
    428                      
     540
     541#+windows-target
     542(defun %windows-realpath (namestring)
     543  (with-filename-cstrs ((path namestring))
     544    (do* ((bufsize 256))
     545         ()
     546      (%stack-block ((buf bufsize))
     547        (let* ((nchars (#_GetFullPathNameW path (ash bufsize -1) buf +null-ptr+)))
     548          (if (eql 0 nchars)
     549            (return nil)
     550            (let* ((max (+ nchars nchars 2)))
     551              (if (> max bufsize)
     552                (setq bufsize max)
     553                (let* ((real (get-foreign-namestring buf)))
     554                  (return (and (%stat real) real)))))))))))
     555
    429556   
    430557;;; This doesn't seem to exist on VxWorks.  It's a POSIX
     
    432559
    433560(defun %realpath (namestring)
     561  ;; It's not at all right to just return the namestring here.
    434562  (when (zerop (length namestring))
    435563    (setq namestring (current-directory-name)))
     564  #+windows-target (%windows-realpath namestring)
     565  #-windows-target
    436566  (%stack-block ((resultbuf #$PATH_MAX))
    437567    (with-filename-cstrs ((name namestring #|(tilde-expand namestring)|#))
     
    485615
    486616
     617#-windows-target
    487618(defun %%rusage (usage &optional (who #$RUSAGE_SELF))
    488619  (int-errno-call (#_getrusage who usage)))
     
    490621
    491622
    492 (defconstant unix-to-universal-time 2208988800)
    493623
    494624(defun %file-write-date (namestring)
     
    497627      (+ date unix-to-universal-time))))
    498628
     629#-windows-target
    499630(defun %file-author (namestring)
    500631  (let* ((uid (nth-value 5 (%stat namestring))))
     
    505636           (%get-cstring (pref pw :passwd.pw_name))))))))
    506637
     638#-windows-target
    507639(defun %utimes (namestring)
    508640  (with-filename-cstrs ((cnamestring namestring))
     
    513645         
    514646
     647#-windows-target
    515648(defun get-uid-from-name (name)
    516649  (with-cstrs ((name name))
     
    519652        (pref pwent :passwd.pw_uid)))))
    520653
    521    
     654
    522655(defun isatty (fd)
     656  #+windows-target (declare (ignore fd))
     657  #+windows-target nil
     658  #-windows-target
    523659  (= 1 (#_isatty fd)))
    524660
    525661(defun %open-dir (namestring)
    526662  (with-filename-cstrs ((name namestring))
    527     (let* ((DIR (#_opendir name)))
     663    (let* ((DIR #+windows-target (syscall syscalls::opendir name)
     664                #-windows-target (#_opendir name)))
    528665      (unless (%null-ptr-p DIR)
    529666        DIR))))
    530667
    531668(defun close-dir (dir)
    532   (#_closedir DIR))
    533 
     669  #+windows-target (syscall syscalls::closedir DIR)
     670  #-windows-target (#_closedir DIR))
     671
     672#-windows-target                        ;want a reentrant version, anyhow
    534673(defun %read-dir (dir)
    535   (rlet ((entry #>dirent)
    536          (presult :address (%null-ptr)))
    537     (let* ((err (#_readdir_r dir entry presult))
    538            (result (%get-ptr presult)))
    539       (declare (fixnum err) (dynamic-extent result))
    540       (when (zerop err)
    541         (unless (%null-ptr-p result)
    542           (get-foreign-namestring (pref result #>dirent.d_name)))))))
    543 
     674  (let* ((res (#_readdir dir)))
     675    (unless (%null-ptr-p res)
     676      (get-foreign-namestring (pref res :dirent.d_name)))))
     677
     678#+windows-target
     679(defun %read-dir (dir)
     680  (let* ((res (syscall syscalls::readdir dir)))
     681    (unless (%null-ptr-p res)
     682      (get-foreign-namestring (pref res :_wdirent.d_name)))))
     683
     684#-windows-target
    544685(defun tcgetpgrp (fd)
    545686  (#_tcgetpgrp fd))
     
    547688(defun getpid ()
    548689  "Return the ID of the OpenMCL OS process."
    549   (int-errno-call (#_getpid)))
     690  #-windows-target
     691  (int-errno-call (#_getpid))
     692  #+windows-target (#_GetCurrentProcessId))
     693
    550694
    551695(defun getuid ()
    552696  "Return the (real) user ID of the current user."
    553   (int-errno-call (#_getuid)))
     697  #+windows-target 0
     698  #-windows-target (int-errno-call (#_getuid)))
    554699
    555700(defun get-user-home-dir (userid)
     
    557702by uid. This value comes from the OS user database, not from the $HOME
    558703environment variable. Returns NIL if there is no user with the ID uid."
     704  #+windows-target
     705  (declare (ignore userid))
     706  #+windows-target
     707  (with-native-utf-16-cstrs ((key "USERPROFILE"))
     708    (let* ((p (#__wgetenv key)))
     709      (unless (%null-ptr-p p)
     710        (get-foreign-namestring p))))
     711  #-windows-target
    559712  (rlet ((pwd :passwd)
    560713         (result :address))
     
    580733(defun %delete-file (name)
    581734  (with-cstrs ((n name))
    582     (int-errno-call (#_unlink n))))
     735    (int-errno-call (#+windows-target #__unlink #-windows-target #_unlink n))))
    583736
    584737(defun os-command (string)
     
    602755      (format nil "OS Error %d" errno)
    603756      (%get-cstring p))))
     757
     758#+windows-target
     759(defun %windows-error-string (error-number) 
     760  (rlet ((pbuffer :address +null-ptr+))
     761    (if (eql 0
     762             (#_FormatMessageW (logior #$FORMAT_MESSAGE_ALLOCATE_BUFFER
     763                                       #$FORMAT_MESSAGE_FROM_SYSTEM
     764                                       #$FORMAT_MESSAGE_IGNORE_INSERTS
     765                                       #$FORMAT_MESSAGE_MAX_WIDTH_MASK)
     766                               +null-ptr+
     767                               (abs error-number)
     768                               0                 ; default langid, more-or-less
     769                               pbuffer
     770                               0
     771                               +null-ptr+))
     772      (format nil "Windows error ~d" (abs error-number))
     773      (let* ((p (%get-ptr pbuffer))
     774             (q (%get-native-utf-16-cstring p)))
     775        (#_LocalFree p)
     776        q))))
     777       
     778                     
    604779
    605780;;; Kind of has something to do with files, and doesn't work in level-0.
     
    701876  `(call-with-string-vector #'(lambda (,var) ,@body) ,@strings))
    702877
    703 (defloadvar *max-os-open-files* (#_getdtablesize))
    704 
     878(defloadvar *max-os-open-files* #-windows-target (#_getdtablesize) #+windows-target 32)
     879
     880#-windows-target
     881(progn
    705882(defun %execvp (argv)
    706883  (#_execvp (%get-ptr argv) argv)
     
    771948     (values nil nil close-in-parent close-on-error))
    772949    (null
    773      (let* ((fd (fd-open "/dev/null" (case direction
     950     (let* ((null-device #+windows-target "nul" #-windows-target "/dev/null")
     951            (fd (fd-open null-device (case direction
    774952                                       (:input #$O_RDONLY)
    775953                                       (:output #$O_WRONLY)
    776954                                       (t #$O_RDWR)))))
    777955       (if (< fd 0)
    778          (signal-file-error fd "/dev/null"))
     956         (signal-file-error fd null-device))
    779957       (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
    780958    ((eql :stream)
     
    11221300      (int-errno-call (#_kill pid signal)))))
    11231301
     1302) ; #-windows-target (progn
     1303
     1304#+windows-target
     1305(progn
     1306(defun temp-file-name (prefix)
     1307  "Returns a unique name for a temporary file, residing in system temp
     1308space, and prefixed with PREFIX."
     1309  (rlet ((buffer (:array :wchar_t #.#$MAX_PATH)))
     1310    (#_GetTempPathW #$MAX_PATH buffer)
     1311    (with-filename-cstrs ((c-prefix prefix))
     1312      (#_GetTempFileNameW buffer c-prefix 0 buffer)
     1313      (%get-native-utf-16-cstring buffer))))
     1314 
     1315(defun get-descriptor-for (object proc close-in-parent close-on-error
     1316                                  &rest keys &key direction (element-type 'character)
     1317                                  &allow-other-keys)
     1318  (etypecase object
     1319    ((eql t)
     1320     (values nil nil close-in-parent close-on-error))
     1321    (null
     1322     (let* ((null-device "nul")
     1323            (fd (fd-open null-device (case direction
     1324                                       (:input #$O_RDONLY)
     1325                                       (:output #$O_WRONLY)
     1326                                       (t #$O_RDWR)))))
     1327       (if (< fd 0)
     1328         (signal-file-error fd null-device))
     1329       (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
     1330    ((eql :stream)
     1331     (multiple-value-bind (read-pipe write-pipe) (pipe)
     1332       (case direction
     1333         (:input
     1334          (values read-pipe
     1335                  (make-fd-stream (fd-uninheritable write-pipe :direction :output)
     1336                                  :direction :output
     1337                                  :element-type element-type
     1338                                  :interactive nil
     1339                                  :basic t
     1340                                  :auto-close t)
     1341                  (cons read-pipe close-in-parent)
     1342                  (cons write-pipe close-on-error)))
     1343         (:output
     1344          (values write-pipe
     1345                  (make-fd-stream (fd-uninheritable read-pipe :direction :input)
     1346                                  :direction :input
     1347                                  :element-type element-type
     1348                                  :interactive nil
     1349                                  :basic t
     1350                                  :auto-close t)
     1351                  (cons write-pipe close-in-parent)
     1352                  (cons read-pipe close-on-error)))
     1353         (t
     1354          (fd-close read-pipe)
     1355          (fd-close write-pipe)
     1356          (report-bad-arg direction '(member :input :output))))))
     1357    ((or pathname string)
     1358     (with-open-stream (file (apply #'open object keys))
     1359       (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)) :direction direction :inheritable t)))
     1360         (values fd
     1361                 nil
     1362                 (cons fd close-in-parent)
     1363                 (cons fd close-on-error)))))
     1364    (fd-stream
     1365     (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
     1366       (values fd
     1367               nil
     1368               (cons fd close-in-parent)
     1369               (cons fd close-on-error))))
     1370    (stream
     1371     (ecase direction
     1372       (:input
     1373        (let* ((tempname (temp-file-name "lisp-temp"))
     1374               (fd (fd-open tempname #$O_RDWR)))
     1375          (if (< fd 0)
     1376            (%errno-disp fd))
     1377          (loop
     1378            (multiple-value-bind (line no-newline)
     1379                (read-line object nil nil)
     1380              (unless line
     1381                (return))
     1382              (let* ((len (length line)))
     1383                (%stack-block ((buf (1+ len)))
     1384                  (%cstr-pointer line buf)
     1385                  (fd-write fd buf len)
     1386                  (if no-newline
     1387                    (return))
     1388                  (setf (%get-byte buf) (char-code #\newline))
     1389                  (fd-write fd buf 1)))))
     1390          (fd-lseek fd 0 #$SEEK_SET)
     1391          (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
     1392       (:output
     1393        (multiple-value-bind (read-pipe write-pipe) (pipe)
     1394          (setf (external-process-watched-fd proc) read-pipe
     1395                (external-process-watched-stream proc) object)
     1396          (incf (car (external-process-token proc)))
     1397          (values write-pipe
     1398                  nil
     1399                  (cons write-pipe close-in-parent)
     1400                  (cons read-pipe close-on-error))))))))
     1401
     1402(defstruct external-process
     1403  pid
     1404  %status
     1405  %exit-code
     1406  pty
     1407  input
     1408  output
     1409  error
     1410  status-hook
     1411  plist
     1412  token
     1413  core
     1414  args
     1415  (signal (make-semaphore))
     1416  (completed (make-semaphore))
     1417  watched-fd
     1418  watched-stream
     1419  )
     1420
     1421(defun external-process-status (proc)
     1422  "Return information about whether an OS subprocess is running; or, if
     1423not, why not; and what its result code was if it completed."
     1424  (require-type proc 'external-process)
     1425  (values (external-process-%status proc)
     1426          (external-process-%exit-code proc)))
     1427
     1428
     1429(defmethod print-object ((p external-process) stream)
     1430  (print-unreadable-object (p stream :type t :identity t)
     1431    (let* ((status (external-process-%status p)))
     1432      (let* ((*print-length* 3))
     1433        (format stream "~a" (external-process-args p)))
     1434      (format stream "[~d] (~a" (external-process-pid p) status)
     1435      (unless (eq status :running)
     1436        (format stream " : ~d" (external-process-%exit-code p)))
     1437      (format stream ")"))))
     1438
     1439(defun run-program (program args &key
     1440                            (wait t) pty
     1441                            input if-input-does-not-exist
     1442                            output (if-output-exists :error)
     1443                            (error :output) (if-error-exists :error)
     1444                            status-hook (element-type 'character)
     1445                            env)
     1446  "Invoke an external program as an OS subprocess of lisp."
     1447  (declare (ignore pty))
     1448  (unless (every #'(lambda (a) (typep a 'simple-string)) args)
     1449    (error "Program args must all be simple strings : ~s" args))
     1450  (push program args)
     1451  (let* ((token (list 0))
     1452         (in-fd nil)
     1453         (in-stream nil)
     1454         (out-fd nil)
     1455         (out-stream nil)
     1456         (error-fd nil)
     1457         (error-stream nil)
     1458         (close-in-parent nil)
     1459         (close-on-error nil)
     1460         (proc
     1461          (make-external-process
     1462           :pid nil
     1463           :args args
     1464           :%status :running
     1465           :input nil
     1466           :output nil
     1467           :error nil
     1468           :token token
     1469           :status-hook status-hook)))
     1470    (unwind-protect
     1471         (progn
     1472           (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
     1473             (get-descriptor-for input proc  nil nil :direction :input
     1474                                 :if-does-not-exist if-input-does-not-exist
     1475                                 :element-type element-type))
     1476           (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
     1477             (get-descriptor-for output proc close-in-parent close-on-error
     1478                                 :direction :output
     1479                                 :if-exists if-output-exists
     1480                                 :element-type element-type))
     1481           (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
     1482             (if (eq error :output)
     1483               (values out-fd out-stream close-in-parent close-on-error)
     1484               (get-descriptor-for error proc close-in-parent close-on-error
     1485                                   :direction :output
     1486                                   :if-exists if-error-exists
     1487                                   :element-type element-type)))
     1488           (setf (external-process-input proc) in-stream
     1489                 (external-process-output proc) out-stream
     1490                 (external-process-error proc) error-stream)
     1491           (process-run-function
     1492            (format nil "Monitor thread for external process ~a" args)
     1493                   
     1494            #'run-external-process proc in-fd out-fd error-fd env)
     1495           (wait-on-semaphore (external-process-signal proc))
     1496           )
     1497      (dolist (fd close-in-parent) (fd-close fd))
     1498      (if (external-process-pid proc)
     1499        (when (and wait (external-process-pid proc))
     1500          (with-interrupts-enabled
     1501              (wait-on-semaphore (external-process-completed proc))))
     1502        (progn
     1503          (dolist (fd close-on-error) (fd-close fd))
     1504          (error "Process execution failed"))))
     1505    proc))
     1506
     1507(let* ((external-processes ())
     1508       (external-processes-lock (make-lock)))
     1509  (defun add-external-process (p)
     1510    (with-lock-grabbed (external-processes-lock)
     1511      (push p external-processes)))
     1512  (defun remove-external-process (p)
     1513    (with-lock-grabbed (external-processes-lock)
     1514      (setq external-processes (delete p external-processes))))
     1515  ;; Likewise
     1516  (defun external-processes ()
     1517    (with-lock-grabbed (external-processes-lock)
     1518      (copy-list external-processes)))
     1519  )
     1520
     1521
     1522(defun pipe ()
     1523  (%stack-block ((filedes 8))
     1524    (syscall syscalls::pipe filedes)
     1525    (values (paref filedes (:array :int)  0) (paref filedes (:array :int)  1))))
     1526
     1527(defun run-external-process (proc in-fd out-fd error-fd &optional env)
     1528  (let* ((args (external-process-args proc))
     1529         (child-pid (exec-with-io-redirection in-fd out-fd error-fd args proc)))
     1530    (when child-pid
     1531      (setf (external-process-pid proc) child-pid)
     1532      (add-external-process proc)
     1533      (signal-semaphore (external-process-signal proc))
     1534      (monitor-external-process proc))))
     1535
     1536(defun join-strings (strings)
     1537  (reduce (lambda (left right) (concatenate 'string left " " right)) strings))
     1538
     1539(defun exec-with-io-redirection (new-in new-out new-err args proc)
     1540  (with-filename-cstrs ((command (join-strings args)))
     1541    (rletz ((proc-info #>PROCESS_INFORMATION)
     1542            (si #>STARTUPINFO))
     1543      (setf (pref si #>STARTUPINFO.cb) (record-length #>STARTUPINFO))
     1544      (setf (pref si #>STARTUPINFO.dwFlags)
     1545            (logior #$STARTF_USESTDHANDLES #$STARTF_USESHOWWINDOW))
     1546      (setf (pref si #>STARTUPINFO.wShowWindow) #$SW_HIDE)
     1547      (setf (pref si #>STARTUPINFO.hStdInput)
     1548            (%int-to-ptr (#__get_osfhandle (or new-in 0))))
     1549      (setf (pref si #>STARTUPINFO.hStdOutput)
     1550            (%int-to-ptr (#__get_osfhandle (or new-out 1))))
     1551      (setf (pref si #>STARTUPINFO.hStdError)
     1552            (%int-to-ptr (#__get_osfhandle (or new-err 2))))
     1553      (if (zerop (#_CreateProcessW (%null-ptr)
     1554                                   command
     1555                                   (%null-ptr)
     1556                                   (%null-ptr)
     1557                                   1
     1558                                   #$CREATE_NEW_CONSOLE
     1559                                   (%null-ptr)
     1560                                   (%null-ptr)
     1561                                   si
     1562                                   proc-info))
     1563        (setf (external-process-%status proc) :error
     1564              (external-process-%exit-code proc) (#_GetLastError))
     1565        (#_CloseHandle (pref proc-info #>PROCESS_INFORMATION.hThread)))
     1566      (pref proc-info #>PROCESS_INFORMATION.hProcess))))
     1567
     1568(defun fd-uninheritable (fd &key direction)
     1569  (let ((new-fd (fd-dup fd :direction direction)))
     1570    (fd-close fd)
     1571    new-fd))
     1572
     1573(defun monitor-external-process (p)
     1574  (let* ((in-fd (external-process-watched-fd p))
     1575         (out-stream (external-process-watched-stream p))
     1576         (token (external-process-token p))
     1577         (terminated))
     1578    (loop
     1579      (when terminated
     1580        (without-interrupts
     1581         (decf (car token))
     1582         (if in-fd (fd-close in-fd))
     1583         (setq in-fd nil)
     1584         (rlet ((code #>DWORD))
     1585           (loop
     1586             (#_GetExitCodeProcess (external-process-pid p) code)
     1587             (unless (eql (pref code #>DWORD) #$STILL_ACTIVE)
     1588               (return)))
     1589           (#_SleepEx 10 #$TRUE)
     1590           (setf (external-process-%exit-code p) (pref code #>DWORD)))
     1591         (#_CloseHandle (external-process-pid p))
     1592         (setf (external-process-pid p) nil)
     1593         (setf (external-process-%status p) :exited)
     1594         (let ((status-hook (external-process-status-hook p)))
     1595           (when status-hook
     1596             (funcall status-hook p)))
     1597         (remove-external-process p)
     1598         (signal-semaphore (external-process-completed p))
     1599         (return)))     
     1600      (if in-fd
     1601        (rlet ((handles (:array #>HANDLE 2)))
     1602          (setf (paref handles (:array #>HANDLE) 0) (external-process-pid p))
     1603          (setf (paref handles (:array #>HANDLE) 1) (#__get_osfhandle in-fd))
     1604          (let ((rc (#_WaitForMultipleObjects 2 handles #$FALSE #$INFINITE)))
     1605            (if (eq rc #$WAIT_OBJECT_0)
     1606              (setf terminated t)
     1607              (%stack-block ((buf 1024))
     1608                (let* ((n (fd-read in-fd buf 1024)))
     1609                  (declare (fixnum n))
     1610                  (if (<= n 0)
     1611                    (setf terminated t)
     1612                    (let* ((string (make-string 1024)))
     1613                      (declare (dynamic-extent string))
     1614                      (%str-from-ptr buf n string)
     1615                      (write-sequence string out-stream :end n))))))))
     1616        (progn
     1617          (#_WaitForSingleObject (external-process-pid p) #$INFINITE)
     1618          (setf terminated t))))))
     1619 
     1620
     1621)                                   ; #+windows-target (progn
    11241622
    11251623;;; EOF on a TTY is transient, but I'm less sure of other cases.
     
    11271625  (case (%unix-fd-kind fd)
    11281626    (:tty t)
     1627    #+windows-target (:character-special t)
    11291628    (t nil)))
    11301629
     
    12831782                  (pref ret :uint)
    12841783                  1))))
    1285             )))
     1784            #+windows-target
     1785              (rlet ((bufsize #>DWORD 64))
     1786                (loop
     1787                  (%stack-block ((info (pref bufsize #>DWORD)))
     1788                    (unless (eql #$FALSE (#_GetLogicalProcessorInformation
     1789                                          info bufsize))
     1790                      (let* ((count 0)
     1791                             (nbytes (pref bufsize #>DWORD)))
     1792                        (return
     1793                          (do* ((i 0 (+ i (record-length #>SYSTEM_LOGICAL_PROCESSOR_INFORMATION))))
     1794                               ((>= i nbytes) count)
     1795                            (when (eql (pref info #>SYSTEM_LOGICAL_PROCESSOR_INFORMATION.Relationship) #$RelationProcessorCore)
     1796                              (incf count))
     1797                            (%incf-ptr info (record-length #>SYSTEM_LOGICAL_PROCESSOR_INFORMATION))))))))))))
    12861798
    12871799(def-load-pointers spin-count ()
     
    12921804
    12931805(defun yield ()
     1806  #+windows-target
     1807  (#_Sleep 0)
     1808  #-windows-target 
    12941809  (#_sched_yield))
    12951810
    1296 (defloadvar *host-page-size* (#_getpagesize))
     1811(defloadvar *host-page-size*
     1812    #-windows-target (#_getpagesize)
     1813    #+windows-target
     1814    (rlet ((info #>SYSTEM_INFO))
     1815      (#_GetSystemInfo info)
     1816      (pref info #>SYSTEM_INFO.dwPageSize))
     1817    )
    12971818
    12981819;;(assert (= (logcount *host-page-size*) 1))
    12991820
     1821#-windows-target
     1822(progn
    13001823(defun map-file-to-ivector (pathname element-type)
    13011824  (let* ((upgraded-type (upgraded-array-element-type element-type))
     
    14701993      (mapped-vector-data-address-and-size v)
    14711994    (percentage-of-resident-pages address nbytes)))
    1472  
     1995)
     1996
     1997#+windows-target
     1998(defun cygpath (winpath)
     1999  "Try to use the Cygwin \"cygpath\" program to map a Windows-style
     2000   pathname to a POSIX-stype Cygwin pathname."
     2001  (let* ((posix-path winpath))
     2002    (with-output-to-string (s)
     2003      (multiple-value-bind (status exit-code)
     2004          (external-process-status
     2005           (run-program "cygpath" (list "-u" winpath) :output s))
     2006        (when (and (eq status :exited)
     2007                   (eql exit-code 0))
     2008          (with-input-from-string (output (get-output-stream-string s))
     2009            (setq posix-path (read-line output nil nil))))))
     2010    posix-path))
     2011
     2012#-windows-target (defun cygpath (path) path)
     2013     
     2014
     2015
     2016
    14732017#+x86-target
    14742018(progn
Note: See TracChangeset for help on using the changeset viewer.