Create empty dump files when there was nothing to dump
authorVladimir Trubilov <vtrubiloff@gmail.com>
Wed, 2 Dec 2015 19:47:23 +0000 (20:47 +0100)
committerBen Gamari <ben@smart-cactus.org>
Wed, 2 Dec 2015 20:56:11 +0000 (21:56 +0100)
This patch creates empty dump file when GHC was run with
`-ddump-rule-firings` (or `-ddump-rule-rewrites`) and `-ddump-to-file`
specified, and there were no rules applied. If dump already exists it
will be overwritten by empty one.

Test Plan: ./validate

Reviewers: austin, thomie, bgamari

Reviewed By: thomie, bgamari

Subscribers: thomie

Projects: #ghc

Differential Revision: https://phabricator.haskell.org/D1514

GHC Trac Issues: #10320

compiler/main/DriverPipeline.hs
compiler/main/DynFlags.hs
compiler/main/ErrUtils.hs
testsuite/tests/driver/Makefile
testsuite/tests/driver/T10320-with-rule.hs [new file with mode: 0644]
testsuite/tests/driver/T10320-without-rules.hs [new file with mode: 0644]
testsuite/tests/driver/all.T

index 2e6bac8..f2bc57e 100644 (file)
@@ -649,8 +649,13 @@ runPipeline' start_phase hsc_env env input_fn
   = do
   -- Execute the pipeline...
   let state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o }
+      dflags = extractDynFlags hsc_env
 
-  evalP (pipeLoop start_phase input_fn) env state
+  -- #10320: Open dump files for writing. Any existing dump specified
+  -- in 'dflags' will be truncated.
+  bracket_ (openDumpFiles dflags)
+           (closeDumpFiles dflags)
+           (evalP (pipeLoop start_phase input_fn) env state)
 
 -- ---------------------------------------------------------------------------
 -- outer pipeline loop
index 7779732..4a443f9 100644 (file)
@@ -806,7 +806,7 @@ data DynFlags = DynFlags {
   -- Names of files which were generated from -ddump-to-file; used to
   -- track which ones we need to truncate because it's our first run
   -- through
-  generatedDumps        :: IORef (Set FilePath),
+  generatedDumps        :: IORef (Map FilePath Handle),
 
   -- hsc dynamic flags
   dumpFlags             :: IntSet,
@@ -1386,7 +1386,7 @@ initDynFlags dflags = do
  refFilesToClean <- newIORef []
  refDirsToClean <- newIORef Map.empty
  refFilesToNotIntermediateClean <- newIORef []
- refGeneratedDumps <- newIORef Set.empty
+ refGeneratedDumps <- newIORef Map.empty
  refRtldInfo <- newIORef Nothing
  refRtccInfo <- newIORef Nothing
  wrapperNum <- newIORef emptyModuleEnv
index efdf808..9fc9e49 100644 (file)
@@ -27,6 +27,8 @@ module ErrUtils (
         dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,
         mkDumpDoc, dumpSDoc,
 
+        openDumpFiles, closeDumpFiles,
+
         --  * Messages during compilation
         putMsg, printInfoForUser, printOutputForUser,
         logInfo, logOutput,
@@ -53,7 +55,7 @@ import System.Directory
 import System.Exit      ( ExitCode(..), exitWith )
 import System.FilePath  ( takeDirectory, (</>) )
 import Data.List
-import qualified Data.Set as Set
+import qualified Data.Map as Map
 import Data.IORef
 import Data.Maybe       ( fromMaybe )
 import Data.Ord
@@ -291,6 +293,15 @@ dumpIfSet_dyn_printer :: PrintUnqualified
 dumpIfSet_dyn_printer printer dflags flag doc
   = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc
 
+-- | a wrapper around 'dumpSDoc'.
+-- First check whether the dump flag is set
+-- Do nothing if it is unset
+--
+-- Makes a dummy write operation into the dump
+dumpIfSet_dyn_empty :: DynFlags -> DumpFlag -> IO ()
+dumpIfSet_dyn_empty dflags flag
+  = when (dopt flag dflags) $ dumpSDoc dflags neverQualify flag "" empty
+
 mkDumpDoc :: String -> SDoc -> SDoc
 mkDumpDoc hdr doc
    = vcat [blankLine,
@@ -300,6 +311,23 @@ mkDumpDoc hdr doc
      where
         line = text (replicate 20 '=')
 
+-- | Open dump files from DynFlags for writing
+--
+-- #10320: This function should be called once before the pipe line
+-- is started. It writes empty data into all requested dumps to initiate
+-- their creation.
+openDumpFiles :: DynFlags -> IO ()
+openDumpFiles dflags
+  = let flags = enumFrom (toEnum 0 :: DumpFlag)
+    in mapM_ (dumpIfSet_dyn_empty dflags) flags
+
+
+-- | Close all opened dump files
+--
+closeDumpFiles :: DynFlags -> IO ()
+closeDumpFiles dflags
+  = do gd <- readIORef $ generatedDumps dflags
+       mapM_ hClose $ Map.elems gd
 
 -- | Write out a dump.
 --      If --dump-to-file is set then this goes to a file.
@@ -315,32 +343,16 @@ dumpSDoc dflags print_unqual flag hdr doc
  = do let mFile = chooseDumpFile dflags flag
           dump_style = mkDumpStyle print_unqual
       case mFile of
-            Just fileName
-                 -> do
-                        let gdref = generatedDumps dflags
-                        gd <- readIORef gdref
-                        let append = Set.member fileName gd
-                            mode = if append then AppendMode else WriteMode
-                        when (not append) $
-                            writeIORef gdref (Set.insert fileName gd)
-                        createDirectoryIfMissing True (takeDirectory fileName)
-                        handle <- openFile fileName mode
-
-                        -- We do not want the dump file to be affected by
-                        -- environment variables, but instead to always use
-                        -- UTF8. See:
-                        -- https://ghc.haskell.org/trac/ghc/ticket/10762
-                        hSetEncoding handle utf8
-
-                        doc' <- if null hdr
-                                then return doc
-                                else do t <- getCurrentTime
-                                        let d = text (show t)
-                                             $$ blankLine
-                                             $$ doc
-                                        return $ mkDumpDoc hdr d
-                        defaultLogActionHPrintDoc dflags handle doc' dump_style
-                        hClose handle
+            Just fileName -> do
+              handle <- getDumpFileHandle dflags fileName
+              doc' <- if null hdr
+                      then return doc
+                      else do t <- getCurrentTime
+                              let d = text (show t)
+                                   $$ blankLine
+                                   $$ doc
+                              return $ mkDumpDoc hdr d
+              defaultLogActionHPrintDoc dflags handle doc' dump_style
 
             -- write the dump to stdout
             Nothing -> do
@@ -349,10 +361,35 @@ dumpSDoc dflags print_unqual flag hdr doc
                     | otherwise = (mkDumpDoc hdr doc, SevDump)
               log_action dflags dflags severity noSrcSpan dump_style doc'
 
+-- | Return a handle assigned to the 'fileName'
+--
+-- If the requested file doesn't exist the new one will be created
+getDumpFileHandle :: DynFlags -> FilePath -> IO Handle
+getDumpFileHandle dflags fileName
+  = do
+      let gdref = generatedDumps dflags
+      gd <- readIORef gdref
+
+      let mHandle = Map.lookup fileName gd
+      case mHandle of
+        Just handle -> return handle
+
+        Nothing -> do
+          createDirectoryIfMissing True (takeDirectory fileName)
+          handle <- openFile fileName WriteMode
+
+          -- We do not want the dump file to be affected by
+          -- environment variables, but instead to always use
+          -- UTF8. See:
+          -- https://ghc.haskell.org/trac/ghc/ticket/10762
+          hSetEncoding handle utf8
+          writeIORef gdref (Map.insert fileName handle gd)
+
+          return handle
 
 -- | Choose where to put a dump file based on DynFlags
 --
-chooseDumpFile :: DynFlags -> DumpFlag -> Maybe String
+chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath
 chooseDumpFile dflags flag
 
         | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file
index 50696a7..f590c73 100644 (file)
@@ -609,3 +609,42 @@ T10182:
        "$(TEST_HC)" $(TEST_HC_OPTS) -c T10182.hs-boot
        "$(TEST_HC)" $(TEST_HC_OPTS) -c T10182a.hs
        "$(TEST_HC)" $(TEST_HC_OPTS) -c T10182.hs
+
+.PHONY: T10320a
+T10320a:
+       # check if an empty .dump-rule-rewrites is created when no rules were applied
+       $(RM) -rf T10320dump
+       $(CP) T10320-without-rules.hs T10320.hs
+       "$(TEST_HC)" $(TEST_HC_OPTS) -O -c T10320.hs -dumpdir T10320dump -ddump-to-file -ddump-rule-rewrites
+       [ -e T10320dump/T10320.dump-rule-rewrites ]
+
+.PHONY: T10320b
+T10320b:
+       # check if an empty .dump-rule-firings is created when no rules were applied
+       $(RM) -rf T10320dump
+       $(CP) T10320-without-rules.hs T10320.hs
+       "$(TEST_HC)" $(TEST_HC_OPTS) -O -c T10320.hs -dumpdir T10320dump -ddump-to-file -ddump-rule-firings
+       [ -e T10320dump/T10320.dump-rule-firings ]
+
+.PHONY: T10320c
+T10320c:
+       # check if existing .dump-rule-rewrites has been rewritten by an empty one when no rules were applied
+       $(RM) -rf T10320dump
+       $(CP) T10320-with-rule.hs T10320.hs
+       "$(TEST_HC)" $(TEST_HC_OPTS) -O -c T10320.hs -dumpdir T10320dump -ddump-to-file -ddump-rule-rewrites    # generate a non-empty dump
+       $(CP) T10320-without-rules.hs T10320.hs
+       "$(TEST_HC)" $(TEST_HC_OPTS) -O -c T10320.hs -dumpdir T10320dump -ddump-to-file -ddump-rule-rewrites
+       [ -e T10320dump/T10320.dump-rule-rewrites -a ! -s T10320dump/T10320.dump-rule-rewrites ]        # check if the file exists and has zero size
+
+.PHONY: T10320d
+T10320d:
+       # check if existing .dump-rule-firings has been rewritten by an empty one when no rules were applied
+       $(RM) -rf T10320dump
+       $(CP) T10320-with-rule.hs T10320.hs
+       "$(TEST_HC)" $(TEST_HC_OPTS) -O -c T10320.hs -dumpdir T10320dump -ddump-to-file -ddump-rule-firings     # generate a non-empty dump
+       $(CP) T10320-without-rules.hs T10320.hs
+       "$(TEST_HC)" $(TEST_HC_OPTS) -O -c T10320.hs -dumpdir T10320dump -ddump-to-file -ddump-rule-firings
+       [ -e T10320dump/T10320.dump-rule-firings -a ! -s T10320dump/T10320.dump-rule-firings ]          # check if the file exists and has zero size
+
+.PHONY: T10320
+T10320: T10320a T10320b T10320c T10320d
diff --git a/testsuite/tests/driver/T10320-with-rule.hs b/testsuite/tests/driver/T10320-with-rule.hs
new file mode 100644 (file)
index 0000000..910db64
--- /dev/null
@@ -0,0 +1,9 @@
+module T10320 where
+
+{-# RULES "rule" forall x. f x = 42 #-}
+
+f :: Int -> Int
+f x = x
+{-# NOINLINE [1] f #-}
+
+n = f (0 :: Int)
diff --git a/testsuite/tests/driver/T10320-without-rules.hs b/testsuite/tests/driver/T10320-without-rules.hs
new file mode 100644 (file)
index 0000000..d070f82
--- /dev/null
@@ -0,0 +1,4 @@
+module T10320 where
+
+n :: Int
+n = 42
index 5c0de6e..3ba8ed5 100644 (file)
@@ -460,3 +460,13 @@ test('T9360b', normal, run_command, ['{compiler} -e "" --interactive'])
 test('T10970', normal, compile_and_run, ['-hide-all-packages -package base -package containers'])
 test('T10970a', normal, compile_and_run, [''])
 test('T4931', normal, compile_and_run, [''])
+test('T10320',
+    [
+        extra_clean([
+                        'T10320dump/T10320.dump-rule-firings',
+                        'T10320dump/T10320.dump-rule-rewrites',
+                        'T10320dump',
+                        'T10320.hs'
+                    ]),
+    ],
+    run_command, ['$MAKE -s --no-print-directory T10320'])