From: sof Date: Mon, 24 Aug 1998 19:22:53 +0000 (+0000) Subject: [project @ 1998-08-24 19:22:47 by sof] X-Git-Tag: Approx_2487_patches~287 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=c172fd348552977483b7a6da8b198b3a462e2af6;p=ghc-hetmet.git [project @ 1998-08-24 19:22:47 by sof] Moved PosixUtil marshaling funs into CString; adjusted imports; don't use lit-lits containing NULL when we've got Addr.nullAddr --- diff --git a/ghc/lib/posix/PosixDB.lhs b/ghc/lib/posix/PosixDB.lhs index 035998c..3ae82e4 100644 --- a/ghc/lib/posix/PosixDB.lhs +++ b/ghc/lib/posix/PosixDB.lhs @@ -17,12 +17,15 @@ module PosixDB ( ) where import ST -import PackedString (psToByteArrayST) import PrelIOBase import Addr import IO import PosixUtil -import Util ( unvectorize ) +import CString ( unvectorize, strcpy, packStringIO ) +\end{code} + + +\begin{code} data GroupEntry = GroupEntry { @@ -42,41 +45,41 @@ data UserEntry = getGroupEntryForID :: GroupID -> IO GroupEntry -getGroupEntryForID gid = - _ccall_ getgrgid gid >>= \ ptr -> - if ptr == (``NULL'' :: Addr) then +getGroupEntryForID gid = do + ptr <- _ccall_ getgrgid gid + if ptr == nullAddr then fail (IOError Nothing NoSuchThing "getGroupEntryForID" "no such group entry") - else + else unpackGroupEntry ptr getGroupEntryForName :: String -> IO GroupEntry -getGroupEntryForName name = - stToIO (psToByteArrayST name) >>= \ gname -> - _ccall_ getgrnam gname >>= \ ptr -> - if ptr == (``NULL'' :: Addr) then +getGroupEntryForName name = do + gname <- packStringIO name + ptr <- _ccall_ getgrnam gname + if ptr == nullAddr then fail (IOError Nothing NoSuchThing "getGroupEntryForName" "no such group entry") - else + else unpackGroupEntry ptr getUserEntryForID :: UserID -> IO UserEntry -getUserEntryForID uid = - _ccall_ getpwuid uid >>= \ ptr -> - if ptr == ``NULL'' then +getUserEntryForID uid = do + ptr <- _ccall_ getpwuid uid + if ptr == nullAddr then fail (IOError Nothing NoSuchThing "getUserEntryForID" "no such user entry") - else + else unpackUserEntry ptr getUserEntryForName :: String -> IO UserEntry -getUserEntryForName name = - stToIO (psToByteArrayST name) >>= \ uname -> - _ccall_ getpwnam uname >>= \ ptr -> - if ptr == ``NULL'' then +getUserEntryForName name = do + uname <- packStringIO name + ptr <- _ccall_ getpwnam uname + if ptr == nullAddr then fail (IOError Nothing NoSuchThing "getUserEntryForName" "no such user entry") - else + else unpackUserEntry ptr \end{code} diff --git a/ghc/lib/posix/PosixFiles.lhs b/ghc/lib/posix/PosixFiles.lhs index 5754a23..5ca22b5 100644 --- a/ghc/lib/posix/PosixFiles.lhs +++ b/ghc/lib/posix/PosixFiles.lhs @@ -71,8 +71,10 @@ import PrelST import ST import PrelIOBase import IO -import IOExts (unsafePerformIO) -import PackedString (psToByteArrayST) +import IOExts ( unsafePerformIO ) +import CString ( packStringIO, allocChars, + freeze, strcpy + ) import Addr import CCall import PrelBase @@ -110,9 +112,9 @@ instance CReturnable DirStream openDirStream :: FilePath -> IO DirStream openDirStream name = - psToByteArrayIO name >>= \dir -> + packStringIO name >>= \dir -> _ccall_ opendir dir >>= \dirp@(A# dirp#) -> - if dirp /= (``NULL''::Addr) + if dirp /= nullAddr then return (DirStream# dirp#) else syserr "openDirStream" @@ -120,7 +122,7 @@ readDirStream :: DirStream -> IO String readDirStream dirp = do setErrorCode noError dirent <- _ccall_ readdir dirp - if dirent /= (``NULL''::Addr) + if dirent /= nullAddr then do str <- _casm_ ``%r = ((struct dirent *)%0)->d_name;'' dirent name <- strcpy str @@ -271,7 +273,7 @@ openFd :: FilePath -> OpenFileFlags -> IO Fd openFd name how maybe_mode (OpenFileFlags append exclusive noctty nonBlock truncate) = - psToByteArrayIO name >>= \file -> + packStringIO name >>= \file -> _ccall_ open file flags mode_w >>= \fd@(I# fd#) -> if fd /= -1 then return (FD# fd#) @@ -306,7 +308,7 @@ openFd name how maybe_mode (OpenFileFlags append exclusive noctty nonBlock trunc createFile :: FilePath -> FileMode -> IO Fd createFile name mode = - psToByteArrayIO name >>= \file -> + packStringIO name >>= \file -> _ccall_ creat file mode >>= \fd@(I# fd#) -> if fd /= -1 then return (FD# fd#) @@ -317,8 +319,8 @@ setFileCreationMask mask = _ccall_ umask mask createLink :: FilePath -> FilePath -> IO () createLink name1 name2 = do - path1 <- psToByteArrayIO name1 - path2 <- psToByteArrayIO name2 + path1 <- packStringIO name1 + path2 <- packStringIO name2 rc <- _ccall_ link path1 path2 if rc == 0 then return () @@ -326,7 +328,7 @@ createLink name1 name2 = do createDirectory :: FilePath -> FileMode -> IO () createDirectory name mode = do -- NB: diff signature from LibDirectory one! - dir <- psToByteArrayIO name + dir <- packStringIO name rc <- _ccall_ mkdir dir mode if rc == 0 then return () @@ -334,7 +336,7 @@ createDirectory name mode = do -- NB: diff signature from LibDirectory one! createNamedPipe :: FilePath -> FileMode -> IO () createNamedPipe name mode = do - pipe <- psToByteArrayIO name + pipe <- packStringIO name rc <-_ccall_ mkfifo pipe mode if rc == 0 then return () @@ -342,7 +344,7 @@ createNamedPipe name mode = do removeLink :: FilePath -> IO () removeLink name = do - path <- psToByteArrayIO name + path <- packStringIO name rc <-_ccall_ unlink path if rc == 0 then return () @@ -350,14 +352,14 @@ removeLink name = do rename :: FilePath -> FilePath -> IO () rename name1 name2 = do - path1 <- psToByteArrayIO name1 - path2 <- psToByteArrayIO name2 + path1 <- packStringIO name1 + path2 <- packStringIO name2 rc <- _ccall_ rename path1 path2 if rc == 0 then return () else syserr "rename" -type FileStatus = ByteArray () +type FileStatus = ByteArray Int type FileID = Int type DeviceID = Int @@ -428,7 +430,7 @@ isNamedPipe stat = unsafePerformIO $ getFileStatus :: FilePath -> IO FileStatus getFileStatus name = do - path <- psToByteArrayIO name + path <- packStringIO name bytes <- allocChars ``sizeof(struct stat)'' rc <- _casm_ ``%r = stat(%0,(struct stat *)%1);'' path bytes if rc == 0 @@ -449,7 +451,7 @@ getFdStatus fd = do fileAccess :: FilePath -> Bool -> Bool -> Bool -> IO Bool fileAccess name read write exec = do - path <- psToByteArrayIO name + path <- packStringIO name rc <- _ccall_ access path flags return (rc == 0) where @@ -460,13 +462,13 @@ fileAccess name read write exec = do fileExist :: FilePath -> IO Bool fileExist name = do - path <- psToByteArrayIO name + path <- packStringIO name rc <- _ccall_ access path (``F_OK''::Int) return (rc == 0) setFileMode :: FilePath -> FileMode -> IO () setFileMode name mode = do - path <- psToByteArrayIO name + path <- packStringIO name rc <- _ccall_ chmod path mode if rc == 0 then return () @@ -474,7 +476,7 @@ setFileMode name mode = do setOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO () setOwnerAndGroup name uid gid = do - path <- psToByteArrayIO name + path <- packStringIO name rc <- _ccall_ chown path uid gid if rc == 0 then return () @@ -482,7 +484,7 @@ setOwnerAndGroup name uid gid = do setFileTimes :: FilePath -> EpochTime -> EpochTime -> IO () setFileTimes name atime mtime = do - path <- psToByteArrayIO name + path <- packStringIO name rc <- _casm_ ``do {struct utimbuf ub; ub.actime = (time_t) %0; ub.modtime = (time_t) %1; %r = utime(%2, &ub);} while(0);'' atime mtime path @@ -493,8 +495,8 @@ setFileTimes name atime mtime = do {- Set access and modification time to current time -} touchFile :: FilePath -> IO () touchFile name = do - path <- psToByteArrayIO name - rc <- _ccall_ utime path (``NULL''::Addr) + path <- packStringIO name + rc <- _ccall_ utime path nullAddr if rc == 0 then return () else syserr "touchFile" @@ -522,7 +524,7 @@ getPathVar v name = pathconf :: Int -> FilePath -> IO Limit pathconf n name = do - path <- psToByteArrayIO name + path <- packStringIO name rc <- _ccall_ pathconf path n if rc /= -1 then return rc diff --git a/ghc/lib/posix/PosixIO.lhs b/ghc/lib/posix/PosixIO.lhs index 1828670..d7354f5 100644 --- a/ghc/lib/posix/PosixIO.lhs +++ b/ghc/lib/posix/PosixIO.lhs @@ -30,13 +30,12 @@ module PosixIO ( ) where import GlaExts -import ST import PrelIOBase import PrelHandle (readHandle, writeHandle, newHandle, getBMode__, getHandleFd ) import IO -import PackedString ( unpackPS, unsafeByteArrayToPS, psToByteArrayST ) import Addr import Foreign +import CString ( freeze, allocChars, packStringIO, unpackNBytesBAIO ) import PosixUtil import PosixFiles ( stdInput, stdOutput, stdError ) @@ -136,7 +135,8 @@ fdRead fd nbytes = do 0 -> fail (IOError Nothing EOF "fdRead" "EOF") n | n == nbytes -> do buf <- freeze bytes - return (unpackPS (unsafeByteArrayToPS buf n), n) + s <- unpackNBytesBAIO buf n + return (s, n) | otherwise -> do -- Let go of the excessively long ByteArray# by copying to a -- shorter one. Maybe we need a new primitive, shrinkCharArray#? @@ -144,11 +144,12 @@ fdRead fd nbytes = do _casm_ ``do {I_ i; for(i = 0; i < %2; i++) ((B_)%0)[i] = ((B_)%1)[i]; } while(0);'' bytes' bytes n buf <- freeze bytes' - return (unpackPS (unsafeByteArrayToPS buf n), n) + s <- unpackNBytesBAIO buf n + return (s, n) fdWrite :: Fd -> String -> IO ByteCount fdWrite fd str = do - buf <- stToIO (psToByteArrayST str) + buf <- packStringIO str rc <- _ccall_ write fd buf (length str) if rc /= -1 then return rc @@ -269,7 +270,7 @@ lockRequest2Int kind = WriteLock -> ``F_WRLCK'' Unlock -> ``F_UNLCK'' -lock2Bytes :: FileLock -> IO (MutableByteArray RealWorld ()) +lock2Bytes :: FileLock -> IO (MutableByteArray RealWorld Int) lock2Bytes (kind, mode, start, len) = do bytes <- allocChars ``sizeof(struct flock)'' _casm_ ``do { struct flock *fl = (struct flock *)%0; @@ -282,7 +283,7 @@ lock2Bytes (kind, mode, start, len) = do return bytes -- where -bytes2ProcessIDAndLock :: MutableByteArray s () -> IO (ProcessID, FileLock) +bytes2ProcessIDAndLock :: MutableByteArray s Int -> IO (ProcessID, FileLock) bytes2ProcessIDAndLock bytes = do ltype <- _casm_ ``%r = ((struct flock *)%0)->l_type;'' bytes lwhence <- _casm_ ``%r = ((struct flock *)%0)->l_whence;'' bytes diff --git a/ghc/lib/posix/PosixProcEnv.lhs b/ghc/lib/posix/PosixProcEnv.lhs index c2f0b0f..c7bf768 100644 --- a/ghc/lib/posix/PosixProcEnv.lhs +++ b/ghc/lib/posix/PosixProcEnv.lhs @@ -54,10 +54,15 @@ import GlaExts import PrelArr (ByteArray(..)) -- see internals import PrelIOBase import IO +import Addr ( nullAddr ) import PosixErr import PosixUtil +import CString ( strcpy, allocWords, freeze, allocChars ) +\end{code} + +\begin{code} getProcessID :: IO ProcessID getProcessID = _ccall_ getpid @@ -76,7 +81,7 @@ setUserID uid = nonzero_error (_ccall_ setuid uid) "setUserID" getLoginName :: IO String getLoginName = do str <- _ccall_ getlogin - if str == ``NULL'' + if str == nullAddr then syserr "getLoginName" else strcpy str @@ -94,7 +99,7 @@ setGroupID gid = nonzero_error (_ccall_ setgid gid) "setGroupID" #if !defined(cygwin32_TARGET_OS) getGroups :: IO [GroupID] getGroups = do - ngroups <- _ccall_ getgroups 0 (``NULL''::Addr) + ngroups <- _ccall_ getgroups 0 nullAddr words <- allocWords ngroups ngroups <- _casm_ ``%r = getgroups(%0,(gid_t *)%1);'' ngroups words if ngroups /= -1 @@ -118,8 +123,8 @@ getEffectiveUserName = do strcpy str {- OLD: - str <- _ccall_ cuserid (``NULL''::Addr) - if str == ``NULL'' + str <- _ccall_ cuserid nullAddr + if str == nullAddr then syserr "getEffectiveUserName" else strcpy str -} @@ -149,7 +154,7 @@ createSession = do then return pgid else syserr "createSession" -type SystemID = ByteArray () +type SystemID = ByteArray Int systemName :: SystemID -> String systemName sid = unsafePerformIO $ do @@ -186,14 +191,14 @@ getSystemID = do epochTime :: IO EpochTime epochTime = do - secs <- _ccall_ time (``NULL''::Addr) + secs <- _ccall_ time nullAddr if secs /= -1 then return secs else syserr "epochTime" -- All times in clock ticks (see getClockTick) -type ProcessTimes = (ClockTick, ByteArray ()) +type ProcessTimes = (ClockTick, ByteArray Int) elapsedTime :: ProcessTimes -> ClockTick elapsedTime (realtime, _) = realtime @@ -228,8 +233,8 @@ getProcessTimes = do #if !defined(cygwin32_TARGET_OS) getControllingTerminalName :: IO FilePath getControllingTerminalName = do - str <- _ccall_ ctermid (``NULL''::Addr) - if str == ``NULL'' + str <- _ccall_ ctermid nullAddr + if str == nullAddr then fail (IOError Nothing NoSuchThing "getControllingTerminalName" "no controlling terminal") else strcpy str #endif @@ -237,7 +242,7 @@ getControllingTerminalName = do getTerminalName :: Fd -> IO FilePath getTerminalName fd = do str <- _ccall_ ttyname fd - if str == ``NULL'' + if str == nullAddr then do err <- try (queryTerminal fd) either (\err -> syserr "getTerminalName") diff --git a/ghc/lib/posix/PosixProcPrim.lhs b/ghc/lib/posix/PosixProcPrim.lhs index 2450a9e..0f3388f 100644 --- a/ghc/lib/posix/PosixProcPrim.lhs +++ b/ghc/lib/posix/PosixProcPrim.lhs @@ -98,11 +98,15 @@ module PosixProcPrim ( import GlaExts import IO import PrelIOBase -import PackedString (psToByteArrayST) -import Foreign -- stable pointers +import Foreign ( makeStablePtr, StablePtr, deRefStablePtr ) +import Addr ( nullAddr ) + import PosixErr import PosixUtil -import Util ( unvectorize ) +import CString ( unvectorize, packStringIO, + allocChars, freeze, vectorize, + allocWords, strcpy + ) import System(ExitCode(..)) import PosixProcEnv (getProcessID) @@ -121,7 +125,7 @@ executeFile :: FilePath -- Command -> Maybe [(String, String)] -- Environment -> IO () executeFile path search args Nothing = do - prog <- psToByteArrayIO path + prog <- packStringIO path argv <- vectorize (basename path:args) (if search then _casm_ ``execvp(%0,(char **)%1);'' prog argv @@ -131,7 +135,7 @@ executeFile path search args Nothing = do syserr "executeFile" executeFile path search args (Just env) = do - prog <- psToByteArrayIO path + prog <- packStringIO path argv <- vectorize (basename path:args) envp <- vectorize (map (\ (name, val) -> name ++ ('=' : val)) env) (if search then @@ -208,21 +212,21 @@ setEnvironment pairs = do getEnvVar :: String -> IO String getEnvVar name = do - str <- psToByteArrayIO name + str <- packStringIO name str <- _ccall_ getenv str - if str == ``NULL'' + if str == nullAddr then fail (IOError Nothing NoSuchThing "getEnvVar" "no such environment variable") else strcpy str setEnvVar :: String -> String -> IO () setEnvVar name value = do - str <- psToByteArrayIO (name ++ ('=' : value)) + str <- packStringIO (name ++ ('=' : value)) nonzero_error (_casm_ ``%r = _setenv(%0);'' str) "setEnvVar" removeEnvVar :: String -> IO () removeEnvVar name = do - str <- psToByteArrayIO name + str <- packStringIO name nonzero_error (_ccall_ delenv str) "removeEnvVar" type Signal = Int @@ -334,7 +338,7 @@ data Handler = Default | Ignore | Catch (IO ()) -type SignalSet = ByteArray () +type SignalSet = ByteArray Int sigSetSize :: Int sigSetSize = ``sizeof(sigset_t)'' diff --git a/ghc/lib/posix/PosixTTY.lhs b/ghc/lib/posix/PosixTTY.lhs index 36bee8d..80c9eb1 100644 --- a/ghc/lib/posix/PosixTTY.lhs +++ b/ghc/lib/posix/PosixTTY.lhs @@ -46,8 +46,12 @@ import Foreign import PosixUtil import PosixErr +import CString ( freeze, allocChars ) -type TerminalAttributes = ByteArray () +\end{code} + +\begin{code} +type TerminalAttributes = ByteArray Int data TerminalMode = InterruptOnBreak | MapCRtoLF diff --git a/ghc/lib/posix/PosixUtil.lhs b/ghc/lib/posix/PosixUtil.lhs index 9334af9..f327852 100644 --- a/ghc/lib/posix/PosixUtil.lhs +++ b/ghc/lib/posix/PosixUtil.lhs @@ -6,25 +6,8 @@ \begin{code} module PosixUtil where -import ST -import PrelST -- ST representation +import GlaExts import PrelIOBase -- IOError representation -import Addr -import Foreign -import CCall -import PrelAddr -import PrelBase ( Int(..), Int#, (==#) - , newIntArray#, unsafeFreezeByteArray#, newCharArray# - , RealWorld - ) - -import MutableArray -import ByteArray -import Array -import PackedString ( unpackCStringIO, packCBytesST, psToByteArrayST ) -import Ix -import PrelArr (StateAndMutableByteArray#(..), StateAndByteArray#(..)) -import Util ( unvectorize ) \end{code} @@ -72,64 +55,6 @@ syserr str = fail (IOError Nothing -- ToDo: better str "") --- Allocate a mutable array of characters with no indices. - -allocChars :: Int -> IO (MutableByteArray RealWorld ()) -allocChars (I# size#) = IO $ \ s# -> - case newCharArray# size# s# of - StateAndMutableByteArray# s2# barr# -> - IOok s2# (MutableByteArray bot barr#) - where - bot = error "PosixUtil.allocChars" - --- Allocate a mutable array of words with no indices - -allocWords :: Int -> IO (MutableByteArray RealWorld ()) -allocWords (I# size#) = IO $ \ s# -> - case newIntArray# size# s# of - StateAndMutableByteArray# s2# barr# -> - IOok s2# (MutableByteArray bot barr#) - where - bot = error "PosixUtil.allocWords" - --- Freeze these index-free mutable arrays - -freeze :: MutableByteArray RealWorld () -> IO (ByteArray ()) -freeze (MutableByteArray ixs arr#) = IO $ \ s# -> - case unsafeFreezeByteArray# arr# s# of - StateAndByteArray# s2# frozen# -> - IOok s2# (ByteArray ixs frozen#) - --- Copy a null-terminated string from outside the heap to --- Haskellized nonsense inside the heap - -strcpy :: Addr -> IO String -strcpy str = unpackCStringIO str - --- Turn a string list into a NULL-terminated vector of null-terminated --- strings No indices...I hate indices. Death to Ix. - -vectorize :: [String] -> IO (ByteArray ()) -vectorize xs = do - arr <- allocWords (len + 1) - fill arr 0 xs - freeze arr - where - len :: Int - len = length xs - - fill :: MutableByteArray RealWorld () -> Int -> [String] -> IO () - fill arr n [] = - _casm_ ``((PP_)%0)[%1] = NULL;'' arr n - fill arr n (x:xs) = - stToIO (psToByteArrayST x) >>= \ barr -> - _casm_ ``((PP_)%0)[%1] = (P_)%2;'' arr n barr - >>= \ () -> - fill arr (n+1) xs - --- Turn a NULL-terminated vector of null-terminated strings into a string list --- unvectorize ... (now in misc/Util.lhs) - -- common templates for system calls nonzero_error :: IO Int -> String -> IO () @@ -146,8 +71,4 @@ minusone_error io err = do then return () else syserr err --- IO versions of a few ST functions. - -psToByteArrayIO = stToIO . psToByteArrayST - \end{code}