diff --git a/src/Build.hs b/src/Build.hs index 8f3aa8d..dc666fb 100644 --- a/src/Build.hs +++ b/src/Build.hs @@ -16,8 +16,9 @@ import System.Exit (ExitCode(..), exitFailure) import System.FileLock (lockFile, tryLockFile, unlockFile, SharedExclusive(..), FileLock) import System.FilePath ((), takeDirectory, dropExtension, takeExtensions, takeFileName, dropExtensions) import System.IO (withFile, IOMode(..), hFileSize, hGetLine) -import System.Process (createProcess, waitForProcess, shell, CreateProcess(..), terminateProcess, ProcessHandle) +import System.Process (createProcess, shell, CreateProcess(..), terminateProcess, ProcessHandle, getProcessExitCode, interruptProcessGroupOf) import System.Posix.Types (ProcessID) +import Control.Concurrent (threadDelay) -- Local imports: import Types @@ -120,8 +121,24 @@ redoIfChange = buildTargets redoIfChange' runFromDo <- isRunFromDoFile case (source, runFromDo) of (True, False) -> targetSourceWarning target - (True, True) -> do initializeSourceDatabase key target - return ExitSuccess + -- Source file encountered from within a .do file. We need to ensure + -- the database is marked as source with a current stamp. However, + -- if the stamp hasn't changed since last time, we can skip the + -- expensive initializeSourceDatabase call (which deletes and recreates + -- the entire database directory). This is important because that + -- delete-recreate cycle opens a corruption window: if the process is + -- killed (e.g. Ctrl+C -> SIGKILL) between the delete and the + -- markSource write, the database is left without a source marker, + -- causing permanent "No rule to build" errors for the file. + -- By skipping unchanged sources, we eliminate this window for the + -- vast majority of source files on incremental builds. + (True, True) -> do + currentStamp <- safeStampTarget target + cachedStamp <- getStamp key + if currentStamp == cachedStamp + then return ExitSuccess + else do initializeSourceDatabase key target + return ExitSuccess (False, _) -> do currentStamp <- safeStampTarget target modified <- isTargetModified key currentStamp @@ -429,9 +446,12 @@ runDoFile key tempKey target currentTimeStamp doFile = do $ insert "REDO_KEY" (keyToFilePath key) $ insert "REDO_SHELL_ARGS" shellArgs $ fromList oldEnv - (_, _, _, processHandle) <- createProcess $ (shell cmd) {env = Just newEnv, cwd = Just redoPath} - -- If we're interrupted while waiting, terminate the child process group - exit <- waitForProcess processHandle `onException` cleanupChild processHandle + (_, _, _, processHandle) <- createProcess $ (shell cmd) {env = Just newEnv, cwd = Just redoPath, create_group = True} + -- Wait for the child using a polling loop instead of blocking waitForProcess. + -- This allows GHC's RTS to deliver async exceptions (e.g. from SIGINT) + -- between polls, preventing the hang that led to the SIGKILL handler. + -- On interruption, kill the child's process group to clean up. + exit <- waitForProcessInterruptible processHandle `onException` cleanupChild processHandle case exit of ExitSuccess -> do exitCode <- moveTempFiles tmp3 tmpStdout targetIsDirectory -- If the target exists, then store the target stamp @@ -582,9 +602,24 @@ shellCmd shellArgs doFile target tmp3 tmpStdout = do readFirstLine = catch (withFile (unDoFile file) ReadMode hGetLine) (\(_ :: SomeException) -> return "") extractShebang shebang = if take 2 shebang == "#!" then return $ drop 2 shebang else return $ "sh -e" ++ shellArgs +-- Wait for a child process using a non-blocking polling loop. +-- Unlike waitForProcess (which blocks in a foreign call to waitpid), +-- this yields to the GHC RTS every 50ms, allowing async exceptions +-- (e.g. UserInterrupt from SIGINT) to be delivered promptly. +waitForProcessInterruptible :: ProcessHandle -> IO ExitCode +waitForProcessInterruptible ph = do + mCode <- getProcessExitCode ph + case mCode of + Just code -> return code + Nothing -> threadDelay 50000 >> waitForProcessInterruptible ph + -- Terminate a child process and its process group on cleanup: cleanupChild :: ProcessHandle -> IO () -cleanupChild ph = catch (terminateProcess ph) (\(_ :: SomeException) -> return ()) +cleanupChild ph = do + -- Try to kill the child's process group first (catches shell children), + -- then fall back to terminating just the child process. + catch (interruptProcessGroupOf ph) (\(_ :: SomeException) -> return ()) + catch (terminateProcess ph) (\(_ :: SomeException) -> return ()) -- Function to check if file exists, and if it does, remove it: safeRemoveTempFile :: FilePath -> IO () diff --git a/src/Database.hs b/src/Database.hs index 5df57e9..4232a77 100644 --- a/src/Database.hs +++ b/src/Database.hs @@ -8,6 +8,7 @@ module Database (clearRedoTempDirectory, initializeTargetDatabase, hasAlwaysDep, getStdoutFile, getTempFile, markBuilt, isBuilt, markErrored, isErrored) where import Control.Exception (catch, SomeException(..)) +import Control.Monad (mapM_) import qualified Data.ByteString.Char8 as BS import Crypto.Hash (hashWith, MD5(..), Digest) import qualified Data.ByteArray @@ -385,12 +386,26 @@ initializeTargetDatabase key doFile = withDatabaseLock key func initializeSourceDatabase :: Key -> Target -> IO () initializeSourceDatabase key target = withDatabaseLock key func - where func = do refreshDatabase key - -- Write out the source file stamp: + where func = do -- Crash-safe initialization: write the source marker FIRST, + -- before any destructive operations. This ensures that if the + -- process is killed at any point (e.g. Ctrl+C -> SIGKILL), the + -- source marker always exists. Without this ordering, a kill + -- between refreshDatabase and markSource leaves the database + -- without a source marker, causing permanent "No rule to build" + -- errors in projects with a catch-all default.do. + createDatabase key + markSource' key + -- Clear any stale target entries that may remain from when + -- this file was previously treated as a build target. + -- These are harmless alongside "y" for isTargetSource, but + -- isErrored is checked before isSource in upToDate, so stale + -- "e" entries would cause unnecessary parent rebuilds. + mapM_ (removeEntry =<<) [getDoFileEntry key, getErroredEntry key, + getIfChangeEntry key, getIfCreateEntry key, + getAlwaysEntry key, getPhonyTargetEntry key] + -- Update the stamp: stamp <- stampTarget target storeStamp' key stamp - -- Mark this target as source: - markSource' key -- Get the database directory for a target: doesDatabaseExist :: Key -> IO Bool diff --git a/src/JobServer.hs b/src/JobServer.hs index f848e8a..b3b410f 100644 --- a/src/JobServer.hs +++ b/src/JobServer.hs @@ -15,13 +15,11 @@ import System.Posix.Process (forkProcess, getProcessStatus, ProcessStatus(..)) import System.Posix.Files (createNamedPipe, ownerReadMode, ownerWriteMode, namedPipeMode, unionFileModes) import Data.Bool (bool) import Control.Monad (void) +import Control.Concurrent (threadDelay) import qualified Data.ByteString.Char8 as BS import Database --- C-level signal reset for forked children -foreign import ccall "reset_signal_handlers" resetSignalHandlers :: IO () - newtype JobServerHandle = JobServerHandle { unJobServerHandle :: (Fd, Fd, Fd) } newtype Token = Token { unToken :: Char } deriving stock (Eq, Show) @@ -107,8 +105,9 @@ runJobs handle (j:jobs) = bool runJob' forkJob =<< tryGetToken handle processId <- forkProcess $ runForkedJob handle j -- Run the rest of the jobs: rets <- runJobs handle jobs + -- Wait for forked child using interruptible polling: maybe (return $ ExitFailure 1 : rets) (returnExitCode rets) - =<< getProcessStatus True False processId + =<< waitOnJobStatus processId -- Run a job on the current process without forking: runJob' = do ret1 <- j rets <- runJobs handle jobs @@ -133,17 +132,28 @@ runJob handle j = bool runJob' forkJob =<< tryGetToken handle -- Always return the token, even if the job fails or is interrupted. runForkedJob :: JobServerHandle -> IO ExitCode -> IO () runForkedJob handle job = do - -- Reset signal handlers to default in forked children. - -- The parent's SIGINT handler does process-group-wide SIGKILL; - -- if forked children inherit it, the child's handler may fire first - -- and kill the parent before the parent's handler gets to run. - resetSignalHandlers _ <- job `onException` returnToken handle returnToken handle --- Wait on job to finish, and return the exit code when it does: +-- Wait on job to finish, and return the exit code when it does. +-- Uses a polling loop instead of blocking getProcessStatus so that +-- GHC's RTS can deliver async exceptions (e.g. SIGINT) between polls. waitOnJob :: ProcessID -> IO ExitCode -waitOnJob pid = maybe (ExitFailure 1) getExitCode <$> getProcessStatus True False pid +waitOnJob pid = do + mStatus <- getProcessStatus False False pid + case mStatus of + Just status -> return $ getExitCode status + Nothing -> threadDelay 50000 >> waitOnJob pid + +-- Wait for a forked process using non-blocking polling, returning +-- the raw ProcessStatus. Yields to the GHC RTS every 50ms so that +-- async exceptions can be delivered. +waitOnJobStatus :: ProcessID -> IO (Maybe ProcessStatus) +waitOnJobStatus pid = do + mStatus <- getProcessStatus False False pid + case mStatus of + Just _ -> return mStatus + Nothing -> threadDelay 50000 >> waitOnJobStatus pid -- Return a job's exit code if it's finished, otherwise return Nothing. tryWaitOnJob :: ProcessID -> IO (Maybe ExitCode) diff --git a/src/Main.hs b/src/Main.hs index b6d32e7..ebefff0 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -19,11 +19,12 @@ import Types import Version import FilePathUtil --- C-level signal handler that SIGKILL's the entire process group on SIGINT/SIGTERM. --- We use C-level sigaction instead of GHC's installHandler because GHC's RTS --- intercepts signals through its own machinery, which may not fire when the --- main thread is blocked in a foreign call (waitpid). -foreign import ccall "install_kill_group_handler" installKillGroupHandler :: IO () +-- Note: The C-level SIGKILL handler (installKillGroupHandler) has been +-- removed. The hang it was solving (GHC RTS not delivering SIGINT while +-- blocked in waitpid) is now fixed by using non-blocking polling loops +-- (waitForProcessInterruptible, waitOnJob) instead of blocking waits. +-- This allows GHC's default SIGINT handling (async exception to main +-- thread) to work correctly, enabling clean shutdown without SIGKILL. -- Redo options: data Options = Options { @@ -219,11 +220,6 @@ mainTop numJobs progName targets = do initializeSession handle <- initializeJobServer numJobs - -- Install C-level signal handler for clean shutdown on Ctrl+C / SIGTERM. - -- Uses raw sigaction to bypass GHC's RTS signal machinery, which may not - -- deliver signals when the main thread is blocked in foreign calls (waitpid). - -- The handler simply SIGKILL's the entire process group. - installKillGroupHandler mainTopInner handle progName targets mainTopInner :: JobServerHandle -> String -> [Target] -> IO() diff --git a/test/375-default-do-source/all.do b/test/375-default-do-source/all.do new file mode 100644 index 0000000..9f64019 --- /dev/null +++ b/test/375-default-do-source/all.do @@ -0,0 +1,2 @@ +redo clean +sh run_tests.sh diff --git a/test/375-default-do-source/clean.do b/test/375-default-do-source/clean.do new file mode 100644 index 0000000..22984be --- /dev/null +++ b/test/375-default-do-source/clean.do @@ -0,0 +1 @@ +rm -rf build src *.log diff --git a/test/375-default-do-source/default.do b/test/375-default-do-source/default.do new file mode 100644 index 0000000..8394c89 --- /dev/null +++ b/test/375-default-do-source/default.do @@ -0,0 +1,25 @@ +# Catch-all default.do that mimics Adamant's project structure: +# NOTE: no shebang — redo adds "sh -e" automatically, so errors propagate. +# - Handles targets in build/ directory by depending on corresponding source +# - Handles "clean" and "all" redo targets +# - Errors on anything else (source files should never reach here) + +case "$1" in + build/*) + # Build targets: depend on the corresponding source file + BASENAME=$(basename "$1") + redo-ifchange "src/$BASENAME" + echo "built from: $(cat "src/$BASENAME")" > "$3" + ;; + clean) + rm -rf build src *.log + ;; + all) + # Run the test script + sh run_tests.sh + ;; + *) + echo "default.do: No rule to build '$1'." >&2 + exit 1 + ;; +esac diff --git a/test/375-default-do-source/run_tests.sh b/test/375-default-do-source/run_tests.sh new file mode 100644 index 0000000..21569a2 --- /dev/null +++ b/test/375-default-do-source/run_tests.sh @@ -0,0 +1,146 @@ +#!/bin/sh +# Tests for source database refresh optimization. +# +# This test directory has a catch-all default.do (like Adamant) that handles +# build/* targets and errors on everything else. Tests verify that source +# files are handled correctly, especially around the optimization that skips +# unnecessary initializeSourceDatabase calls for unchanged source files. + +set -e + +############################################################################## +# Helpers +############################################################################## +get_db_dir() { + DB_KEY=$(printf '%s' "$1" | md5sum | awk '{print toupper($1)}') + echo "$HOME/.redo/database/$(echo $DB_KEY | cut -c1-3)/$(echo $DB_KEY | cut -c4-9)/$(echo $DB_KEY | cut -c10-21)/$(echo $DB_KEY | cut -c22-)" +} +get_stamp_dir() { + DB_KEY=$(printf '%s' "$1" | md5sum | awk '{print toupper($1)}') + echo "$HOME/.redo/stamps/$(echo $DB_KEY | cut -c1-3)/$(echo $DB_KEY | cut -c4-9)/$(echo $DB_KEY | cut -c10-21)/$(echo $DB_KEY | cut -c22-)" +} +clean_redo_state() { + # Clean redo DB and stamps for a file + rm -rf "$(get_db_dir "$1")" "$(get_stamp_dir "$1")" +} + +PASS=0 +FAIL=0 +pass() { echo "PASS: $1" >&2; PASS=$((PASS + 1)); } +fail() { echo "FAIL: $1" >&2; FAIL=$((FAIL + 1)); } + +############################################################################## +# Test 1: Unchanged source files skip DB refresh +# +# After an initial build, rebuilding with an unchanged source file should +# NOT call initializeSourceDatabase (which deletes and recreates the DB). +# We verify by checking that the source marker persists and the DB directory +# inode is unchanged (not deleted and recreated). +############################################################################## +test_skip_unchanged() { + mkdir -p src build + SRC_PATH="$(cd src && pwd)/data.txt" + BUILD_PATH="$(cd build && pwd)/data.txt" + clean_redo_state "$SRC_PATH" + clean_redo_state "$BUILD_PATH" + ../flush-cache + + echo "content v1" > src/data.txt + + # Initial build — creates source DB with stamp + redo-ifchange build/data.txt + test "$(cat build/data.txt)" = "built from: content v1" || { fail "skip-unchanged: wrong initial content"; return; } + + SRC_DB=$(get_db_dir "$SRC_PATH") + test -d "$SRC_DB/y" || { fail "skip-unchanged: no source marker after initial build"; return; } + + # Record the DB directory's inode to detect if it gets recreated + INODE_BEFORE=$(stat -c %i "$SRC_DB" 2>/dev/null || stat -f %i "$SRC_DB" 2>/dev/null) + + # Rebuild with no changes — should skip initializeSourceDatabase + ../flush-cache + redo-ifchange build/data.txt + + # Source marker must still exist + test -d "$SRC_DB/y" || { fail "skip-unchanged: source marker lost on rebuild"; return; } + + # DB directory inode should be the same (not deleted and recreated) + INODE_AFTER=$(stat -c %i "$SRC_DB" 2>/dev/null || stat -f %i "$SRC_DB" 2>/dev/null) + test "$INODE_BEFORE" = "$INODE_AFTER" || { fail "skip-unchanged: DB was recreated (inode changed: $INODE_BEFORE -> $INODE_AFTER)"; return; } + + pass "skip-unchanged" + rm -rf src build +} + +############################################################################## +# Test 2: Changed source files DO get DB refresh +# +# When a source file changes (different mtime), initializeSourceDatabase +# must run to update the stamp and trigger dependent rebuilds. +############################################################################## +test_refresh_on_change() { + mkdir -p src build + SRC_PATH="$(cd src && pwd)/data.txt" + BUILD_PATH="$(cd build && pwd)/data.txt" + clean_redo_state "$SRC_PATH" + clean_redo_state "$BUILD_PATH" + ../flush-cache + + echo "content v1" > src/data.txt + redo-ifchange build/data.txt + test "$(cat build/data.txt)" = "built from: content v1" || { fail "refresh-on-change: wrong initial content"; return; } + + # Modify the source + ../sleep + echo "content v2" > src/data.txt + ../flush-cache + + # Rebuild — should detect change and rebuild dependent target + redo-ifchange build/data.txt + test "$(cat build/data.txt)" = "built from: content v2" || { fail "refresh-on-change: change not detected"; return; } + + # Source marker must still exist + SRC_DB=$(get_db_dir "$SRC_PATH") + test -d "$SRC_DB/y" || { fail "refresh-on-change: source marker lost after change"; return; } + + pass "refresh-on-change" + rm -rf src build +} + +############################################################################## +# Test 3: New source files get properly initialized +# +# A source file encountered for the first time (no DB, no stamp) must have +# initializeSourceDatabase called to create the DB with source marker. +############################################################################## +test_new_source_init() { + mkdir -p src build + SRC_PATH="$(cd src && pwd)/data.txt" + BUILD_PATH="$(cd build && pwd)/data.txt" + clean_redo_state "$SRC_PATH" + clean_redo_state "$BUILD_PATH" + ../flush-cache + + echo "new content" > src/data.txt + + # First build — source has no DB at all + redo-ifchange build/data.txt + test "$(cat build/data.txt)" = "built from: new content" || { fail "new-source-init: wrong content"; return; } + + SRC_DB=$(get_db_dir "$SRC_PATH") + test -d "$SRC_DB/y" || { fail "new-source-init: source marker not created"; return; } + + pass "new-source-init" + rm -rf src build +} + +############################################################################## +# Run all tests +############################################################################## +test_skip_unchanged +test_refresh_on_change +test_new_source_init + +echo "" >&2 +echo "Results: $PASS passed, $FAIL failed" >&2 +test "$FAIL" -eq 0