never executed always true always false
    1 
    2 
    3 -----------------------------------------------------------------------------
    4 --
    5 -- Makefile Dependency Generation
    6 --
    7 -- (c) The University of Glasgow 2005
    8 --
    9 -----------------------------------------------------------------------------
   10 
   11 module GHC.Driver.MakeFile
   12    ( doMkDependHS
   13    )
   14 where
   15 
   16 import GHC.Prelude
   17 
   18 import qualified GHC
   19 import GHC.Driver.Config.Finder
   20 import GHC.Driver.Monad
   21 import GHC.Driver.Session
   22 import GHC.Driver.Ppr
   23 import GHC.Utils.Misc
   24 import GHC.Driver.Env
   25 import GHC.Driver.Errors.Types
   26 import qualified GHC.SysTools as SysTools
   27 import GHC.Data.Graph.Directed ( SCC(..) )
   28 import GHC.Utils.Outputable
   29 import GHC.Utils.Panic
   30 import GHC.Utils.Panic.Plain
   31 import GHC.Types.SourceError
   32 import GHC.Types.SrcLoc
   33 import GHC.Types.PkgQual
   34 import Data.List (partition)
   35 import GHC.Utils.TmpFs
   36 
   37 import GHC.Iface.Load (cannotFindModule)
   38 
   39 import GHC.Unit.Module
   40 import GHC.Unit.Module.ModSummary
   41 import GHC.Unit.Module.Graph
   42 import GHC.Unit.Finder
   43 
   44 import GHC.Utils.Exception
   45 import GHC.Utils.Error
   46 import GHC.Utils.Logger
   47 
   48 import System.Directory
   49 import System.FilePath
   50 import System.IO
   51 import System.IO.Error  ( isEOFError )
   52 import Control.Monad    ( when, forM_ )
   53 import Data.Maybe       ( isJust )
   54 import Data.IORef
   55 import qualified Data.Set as Set
   56 
   57 -----------------------------------------------------------------
   58 --
   59 --              The main function
   60 --
   61 -----------------------------------------------------------------
   62 
   63 doMkDependHS :: GhcMonad m => [FilePath] -> m ()
   64 doMkDependHS srcs = do
   65     logger <- getLogger
   66 
   67     -- Initialisation
   68     dflags0 <- GHC.getSessionDynFlags
   69 
   70     -- We kludge things a bit for dependency generation. Rather than
   71     -- generating dependencies for each way separately, we generate
   72     -- them once and then duplicate them for each way's osuf/hisuf.
   73     -- We therefore do the initial dependency generation with an empty
   74     -- way and .o/.hi extensions, regardless of any flags that might
   75     -- be specified.
   76     let dflags1 = dflags0
   77             { targetWays_ = Set.empty
   78             , hiSuf_      = "hi"
   79             , objectSuf_  = "o"
   80             }
   81     GHC.setSessionDynFlags dflags1
   82 
   83     -- If no suffix is provided, use the default -- the empty one
   84     let dflags = if null (depSuffixes dflags1)
   85                  then dflags1 { depSuffixes = [""] }
   86                  else dflags1
   87 
   88     tmpfs <- hsc_tmpfs <$> getSession
   89     files <- liftIO $ beginMkDependHS logger tmpfs dflags
   90 
   91     -- Do the downsweep to find all the modules
   92     targets <- mapM (\s -> GHC.guessTarget s Nothing Nothing) srcs
   93     GHC.setTargets targets
   94     let excl_mods = depExcludeMods dflags
   95     module_graph <- GHC.depanal excl_mods True {- Allow dup roots -}
   96 
   97     -- Sort into dependency order
   98     -- There should be no cycles
   99     let sorted = GHC.topSortModuleGraph False module_graph Nothing
  100 
  101     -- Print out the dependencies if wanted
  102     liftIO $ debugTraceMsg logger 2 (text "Module dependencies" $$ ppr sorted)
  103 
  104     -- Process them one by one, dumping results into makefile
  105     -- and complaining about cycles
  106     hsc_env <- getSession
  107     root <- liftIO getCurrentDirectory
  108     mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted
  109 
  110     -- If -ddump-mod-cycles, show cycles in the module graph
  111     liftIO $ dumpModCycles logger module_graph
  112 
  113     -- Tidy up
  114     liftIO $ endMkDependHS logger files
  115 
  116     -- Unconditional exiting is a bad idea.  If an error occurs we'll get an
  117     --exception; if that is not caught it's fine, but at least we have a
  118     --chance to find out exactly what went wrong.  Uncomment the following
  119     --line if you disagree.
  120 
  121     --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1)
  122 
  123 -----------------------------------------------------------------
  124 --
  125 --              beginMkDependHs
  126 --      Create a temporary file,
  127 --      find the Makefile,
  128 --      slurp through it, etc
  129 --
  130 -----------------------------------------------------------------
  131 
  132 data MkDepFiles
  133   = MkDep { mkd_make_file :: FilePath,          -- Name of the makefile
  134             mkd_make_hdl  :: Maybe Handle,      -- Handle for the open makefile
  135             mkd_tmp_file  :: FilePath,          -- Name of the temporary file
  136             mkd_tmp_hdl   :: Handle }           -- Handle of the open temporary file
  137 
  138 beginMkDependHS :: Logger -> TmpFs -> DynFlags -> IO MkDepFiles
  139 beginMkDependHS logger tmpfs dflags = do
  140         -- open a new temp file in which to stuff the dependency info
  141         -- as we go along.
  142   tmp_file <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "dep"
  143   tmp_hdl <- openFile tmp_file WriteMode
  144 
  145         -- open the makefile
  146   let makefile = depMakefile dflags
  147   exists <- doesFileExist makefile
  148   mb_make_hdl <-
  149         if not exists
  150         then return Nothing
  151         else do
  152            makefile_hdl <- openFile makefile ReadMode
  153 
  154                 -- slurp through until we get the magic start string,
  155                 -- copying the contents into dep_makefile
  156            let slurp = do
  157                 l <- hGetLine makefile_hdl
  158                 if (l == depStartMarker)
  159                         then return ()
  160                         else do hPutStrLn tmp_hdl l; slurp
  161 
  162                 -- slurp through until we get the magic end marker,
  163                 -- throwing away the contents
  164            let chuck = do
  165                 l <- hGetLine makefile_hdl
  166                 if (l == depEndMarker)
  167                         then return ()
  168                         else chuck
  169 
  170            catchIO slurp
  171                 (\e -> if isEOFError e then return () else ioError e)
  172            catchIO chuck
  173                 (\e -> if isEOFError e then return () else ioError e)
  174 
  175            return (Just makefile_hdl)
  176 
  177 
  178         -- write the magic marker into the tmp file
  179   hPutStrLn tmp_hdl depStartMarker
  180 
  181   return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl,
  182                   mkd_tmp_file  = tmp_file, mkd_tmp_hdl  = tmp_hdl})
  183 
  184 
  185 -----------------------------------------------------------------
  186 --
  187 --              processDeps
  188 --
  189 -----------------------------------------------------------------
  190 
  191 processDeps :: DynFlags
  192             -> HscEnv
  193             -> [ModuleName]
  194             -> FilePath
  195             -> Handle           -- Write dependencies to here
  196             -> SCC ModuleGraphNode
  197             -> IO ()
  198 -- Write suitable dependencies to handle
  199 -- Always:
  200 --                      this.o : this.hs
  201 --
  202 -- If the dependency is on something other than a .hi file:
  203 --                      this.o this.p_o ... : dep
  204 -- otherwise
  205 --                      this.o ...   : dep.hi
  206 --                      this.p_o ... : dep.p_hi
  207 --                      ...
  208 -- (where .o is $osuf, and the other suffixes come from
  209 -- the cmdline -s options).
  210 --
  211 -- For {-# SOURCE #-} imports the "hi" will be "hi-boot".
  212 
  213 processDeps dflags _ _ _ _ (CyclicSCC nodes)
  214   =     -- There shouldn't be any cycles; report them
  215     throwGhcExceptionIO $ ProgramError $
  216       showSDoc dflags $ GHC.cyclicModuleErr nodes
  217 
  218 processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode node))
  219   =     -- There shouldn't be any backpack instantiations; report them as well
  220     throwGhcExceptionIO $ ProgramError $
  221       showSDoc dflags $
  222         vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:"
  223              , nest 2 $ ppr node ]
  224 
  225 processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode (ExtendedModSummary node _)))
  226   = do  { let extra_suffixes = depSuffixes dflags
  227               include_pkg_deps = depIncludePkgDeps dflags
  228               src_file  = msHsFilePath node
  229               obj_file  = msObjFilePath node
  230               obj_files = insertSuffixes obj_file extra_suffixes
  231 
  232               do_imp loc is_boot pkg_qual imp_mod
  233                 = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod
  234                                                is_boot include_pkg_deps
  235                      ; case mb_hi of {
  236                            Nothing      -> return () ;
  237                            Just hi_file -> do
  238                      { let hi_files = insertSuffixes hi_file extra_suffixes
  239                            write_dep (obj,hi) = writeDependency root hdl [obj] hi
  240 
  241                         -- Add one dependency for each suffix;
  242                         -- e.g.         A.o   : B.hi
  243                         --              A.x_o : B.x_hi
  244                      ; mapM_ write_dep (obj_files `zip` hi_files) }}}
  245 
  246 
  247                 -- Emit std dependency of the object(s) on the source file
  248                 -- Something like       A.o : A.hs
  249         ; writeDependency root hdl obj_files src_file
  250 
  251           -- add dependency between objects and their corresponding .hi-boot
  252           -- files if the module has a corresponding .hs-boot file (#14482)
  253         ; when (isBootSummary node == IsBoot) $ do
  254             let hi_boot = msHiFilePath node
  255             let obj     = removeBootSuffix (msObjFilePath node)
  256             forM_ extra_suffixes $ \suff -> do
  257                let way_obj     = insertSuffixes obj     [suff]
  258                let way_hi_boot = insertSuffixes hi_boot [suff]
  259                mapM_ (writeDependency root hdl way_obj) way_hi_boot
  260 
  261                 -- Emit a dependency for each CPP import
  262         ; when (depIncludeCppDeps dflags) $ do
  263             -- CPP deps are descovered in the module parsing phase by parsing
  264             -- comment lines left by the preprocessor.
  265             -- Note that GHC.parseModule may throw an exception if the module
  266             -- fails to parse, which may not be desirable (see #16616).
  267           { session <- Session <$> newIORef hsc_env
  268           ; parsedMod <- reflectGhc (GHC.parseModule node) session
  269           ; mapM_ (writeDependency root hdl obj_files)
  270                   (GHC.pm_extra_src_files parsedMod)
  271           }
  272 
  273                 -- Emit a dependency for each import
  274 
  275         ; let do_imps is_boot idecls = sequence_
  276                     [ do_imp loc is_boot mb_pkg mod
  277                     | (mb_pkg, L loc mod) <- idecls,
  278                       mod `notElem` excl_mods ]
  279 
  280         ; do_imps IsBoot (ms_srcimps node)
  281         ; do_imps NotBoot (ms_imps node)
  282         }
  283 
  284 
  285 findDependency  :: HscEnv
  286                 -> SrcSpan
  287                 -> PkgQual              -- package qualifier, if any
  288                 -> ModuleName           -- Imported module
  289                 -> IsBootInterface      -- Source import
  290                 -> Bool                 -- Record dependency on package modules
  291                 -> IO (Maybe FilePath)  -- Interface file
  292 findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do
  293   let fc        = hsc_FC hsc_env
  294   let home_unit = hsc_home_unit hsc_env
  295   let units     = hsc_units hsc_env
  296   let dflags    = hsc_dflags hsc_env
  297   let fopts     = initFinderOpts dflags
  298   -- Find the module; this will be fast because
  299   -- we've done it once during downsweep
  300   r <- findImportedModule fc fopts units home_unit imp pkg
  301   case r of
  302     Found loc _
  303         -- Home package: just depend on the .hi or hi-boot file
  304         | isJust (ml_hs_file loc) || include_pkg_deps
  305         -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
  306 
  307         -- Not in this package: we don't need a dependency
  308         | otherwise
  309         -> return Nothing
  310 
  311     fail ->
  312         throwOneError $
  313           mkPlainErrorMsgEnvelope srcloc $
  314           GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $
  315              cannotFindModule hsc_env imp fail
  316 
  317 -----------------------------
  318 writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
  319 -- (writeDependency r h [t1,t2] dep) writes to handle h the dependency
  320 --      t1 t2 : dep
  321 writeDependency root hdl targets dep
  322   = do let -- We need to avoid making deps on
  323            --     c:/foo/...
  324            -- on cygwin as make gets confused by the :
  325            -- Making relative deps avoids some instances of this.
  326            dep' = makeRelative root dep
  327            forOutput = escapeSpaces . reslash Forwards . normalise
  328            output = unwords (map forOutput targets) ++ " : " ++ forOutput dep'
  329        hPutStrLn hdl output
  330 
  331 -----------------------------
  332 insertSuffixes
  333         :: FilePath     -- Original filename;   e.g. "foo.o"
  334         -> [String]     -- Suffix prefixes      e.g. ["x_", "y_"]
  335         -> [FilePath]   -- Zapped filenames     e.g. ["foo.x_o", "foo.y_o"]
  336         -- Note that the extra bit gets inserted *before* the old suffix
  337         -- We assume the old suffix contains no dots, so we know where to
  338         -- split it
  339 insertSuffixes file_name extras
  340   = [ basename <.> (extra ++ suffix) | extra <- extras ]
  341   where
  342     (basename, suffix) = case splitExtension file_name of
  343                          -- Drop the "." from the extension
  344                          (b, s) -> (b, drop 1 s)
  345 
  346 
  347 -----------------------------------------------------------------
  348 --
  349 --              endMkDependHs
  350 --      Complete the makefile, close the tmp file etc
  351 --
  352 -----------------------------------------------------------------
  353 
  354 endMkDependHS :: Logger -> MkDepFiles -> IO ()
  355 
  356 endMkDependHS logger
  357    (MkDep { mkd_make_file = makefile, mkd_make_hdl =  makefile_hdl,
  358             mkd_tmp_file  = tmp_file, mkd_tmp_hdl  =  tmp_hdl })
  359   = do
  360   -- write the magic marker into the tmp file
  361   hPutStrLn tmp_hdl depEndMarker
  362 
  363   case makefile_hdl of
  364      Nothing  -> return ()
  365      Just hdl -> do
  366         -- slurp the rest of the original makefile and copy it into the output
  367         SysTools.copyHandle hdl tmp_hdl
  368         hClose hdl
  369 
  370   hClose tmp_hdl  -- make sure it's flushed
  371 
  372         -- Create a backup of the original makefile
  373   when (isJust makefile_hdl) $ do
  374     showPass logger ("Backing up " ++ makefile)
  375     SysTools.copyFile makefile (makefile++".bak")
  376 
  377         -- Copy the new makefile in place
  378   showPass logger "Installing new makefile"
  379   SysTools.copyFile tmp_file makefile
  380 
  381 
  382 -----------------------------------------------------------------
  383 --              Module cycles
  384 -----------------------------------------------------------------
  385 
  386 dumpModCycles :: Logger -> ModuleGraph -> IO ()
  387 dumpModCycles logger module_graph
  388   | not (logHasDumpFlag logger Opt_D_dump_mod_cycles)
  389   = return ()
  390 
  391   | null cycles
  392   = putMsg logger (text "No module cycles")
  393 
  394   | otherwise
  395   = putMsg logger (hang (text "Module cycles found:") 2 pp_cycles)
  396   where
  397     topoSort = filterToposortToModules $
  398       GHC.topSortModuleGraph True module_graph Nothing
  399 
  400     cycles :: [[ModSummary]]
  401     cycles =
  402       [ c | CyclicSCC c <- topoSort ]
  403 
  404     pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> text "----------")
  405                         $$ pprCycle c $$ blankLine
  406                      | (n,c) <- [1..] `zip` cycles ]
  407 
  408 pprCycle :: [ModSummary] -> SDoc
  409 -- Print a cycle, but show only the imports within the cycle
  410 pprCycle summaries = pp_group (CyclicSCC summaries)
  411   where
  412     cycle_mods :: [ModuleName]  -- The modules in this cycle
  413     cycle_mods = map (moduleName . ms_mod) summaries
  414 
  415     pp_group (AcyclicSCC ms) = pp_ms ms
  416     pp_group (CyclicSCC mss)
  417         = assert (not (null boot_only)) $
  418                 -- The boot-only list must be non-empty, else there would
  419                 -- be an infinite chain of non-boot imports, and we've
  420                 -- already checked for that in processModDeps
  421           pp_ms loop_breaker $$ vcat (map pp_group groups)
  422         where
  423           (boot_only, others) = partition is_boot_only mss
  424           is_boot_only ms = not (any in_group (map snd (ms_imps ms)))
  425           in_group (L _ m) = m `elem` group_mods
  426           group_mods = map (moduleName . ms_mod) mss
  427 
  428           loop_breaker = head boot_only
  429           all_others   = tail boot_only ++ others
  430           groups = filterToposortToModules $
  431             GHC.topSortModuleGraph True (mkModuleGraph $ extendModSummaryNoDeps <$> all_others) Nothing
  432 
  433     pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))
  434                        <+> (pp_imps empty (map snd (ms_imps summary)) $$
  435                             pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary)))
  436         where
  437           mod_str = moduleNameString (moduleName (ms_mod summary))
  438 
  439     pp_imps :: SDoc -> [Located ModuleName] -> SDoc
  440     pp_imps _    [] = empty
  441     pp_imps what lms
  442         = case [m | L _ m <- lms, m `elem` cycle_mods] of
  443             [] -> empty
  444             ms -> what <+> text "imports" <+>
  445                                 pprWithCommas ppr ms
  446 
  447 -----------------------------------------------------------------
  448 --
  449 --              Flags
  450 --
  451 -----------------------------------------------------------------
  452 
  453 depStartMarker, depEndMarker :: String
  454 depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
  455 depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"