Question

作为一个学习练习，我在Haskell中创建了一个小shell，支持后台作业和简单的stdout重定向。但是，我的代码中似乎存在竞争条件，我不明白。我正在使用System.Posix。

-- ... imports ...

data Redirection = None
                 | StdOut String
                 deriving (Show)

data Command = Command
  { cProgramName :: String
  , cProgramArgs :: [String]
  , cRedirection :: Redirection
  , cBackground  :: Bool
  } deriving (Show)

data Sync = Sync
  { sMVar        :: MVar ()
  , sRunningJobs :: IORef [ProcessID]
  , sDeadJobs    :: IORef [ProcessID]
  }

withLock :: Sync -> IO () -> IO ()
withLock (Sync mvar _ _) action = do
  putMVar mvar ()
  action
  takeMVar mvar

-- ... parser stuff ...

resolveLine :: Sync -> String -> IO Bool
resolveLine _ "quit" = return False
resolveLine sync line = do
  case P.parse lineParser "" line of
    Left err -> putStrLn (show err)
    Right Nothing -> return ()
    Right (Just (Command prog args redirect bg)) ->
      case Map.lookup prog builtins of
        (Just cmd) -> cmd sync args
        Nothing    -> do
          pid <- forkProcess $ do
            case redirect of
              None -> return ()
              StdOut target -> do
                fd <- openFd target WriteOnly (Just 420) defaultFileFlags { trunc = True }
                void $ dupTo fd stdOutput
                closeFd fd
            executeFile prog True args Nothing
          when bg $
            withLock sync $ modifyIORef (sRunningJobs sync) (pid:)

  return True

runShell :: Sync -> IO ()
runShell sync = do
  wd   <- getCurrentDirectory
  hd   <- getHomeDirectory
  line <- readline $ shortenDirectory hd wd ++ " > "
  case line of
    Nothing     -> putStrLn "" >> return ()
    Just line   -> do
      addHistory line
      -- Reap dead children.
      withLock sync $ readIORef (sDeadJobs sync) >>= mapM_
        (\pid -> do
            getProcessStatus True True pid
            modifyIORef (sDeadJobs sync) (delete pid)
        )
      go <- resolveLine sync line
      when go $ runShell sync

  where shortenDirectory hd wd = if hd `isPrefixOf` wd
                                 then "~" ++ drop (length hd) wd
                                 else wd

handleSigChild :: Sync -> SignalInfo -> IO ()
handleSigChild sync si = do
  withLock sync $ do
    modifyIORef (sRunningJobs sync) (delete pid)
    modifyIORef (sDeadJobs sync) (pid:)
  where
    pid = siginfoPid $ siginfoSpecific si

main :: IO ()
main = do
  mvar <- newEmptyMVar
  rjobs <- newIORef []
  djobs <- newIORef []
  void $ installHandler sigCHLD (CatchInfo $ handleSigChild $ Sync mvar rjobs djobs) Nothing
  runShell $ Sync mvar rjobs djobs

有时，当我在后台作业上运行kill时，不会调用handleSigChild函数导致僵尸进程，因为子代的pid未添加到共享列表中将要收获的死进程。我在shell中运行kill命令。

为什么处理程序只执行一次？是因为kill进程本身和被杀死的进程几乎同时发送信号？我该如何解决？

Haskell：POSIX：SIGCHLD信号处理程序有时不被调用

0 个答案: