Skip unnecessary source database refresh for unchanged files

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 ()

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

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)

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()

test/375-default-do-source/all.do

@@ -0,0 +1,2 @@
+redo clean
+sh run_tests.sh

test/375-default-do-source/clean.do

@@ -0,0 +1 @@
+rm -rf build src *.log

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

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