GHC/Driver/MakeFile.hs

    {-# LANGUAGE CPP #-}

    -----------------------------------------------------------------------------
    --
    -- Makefile Dependency Generation
    --
    -- (c) The University of Glasgow 2005
    --
    -----------------------------------------------------------------------------

    module GHC.Driver.MakeFile
       ( doMkDependHS
       )
    where

    #include "HsVersions.h"

    import GHC.Prelude

    import qualified GHC
    import GHC.Driver.Monad
    import GHC.Driver.Session
    import GHC.Driver.Ppr
    import GHC.Utils.Misc
    import GHC.Driver.Env
    import qualified GHC.SysTools as SysTools
    import GHC.Data.Graph.Directed ( SCC(..) )
    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Types.SourceError
    import GHC.Types.SrcLoc
    import Data.List (partition)
    import GHC.Data.FastString
    import GHC.Utils.TmpFs

    import GHC.Iface.Load (cannotFindModule)

    import GHC.Unit.Module
    import GHC.Unit.Module.ModSummary
    import GHC.Unit.Module.Graph
    import GHC.Unit.Finder

    import GHC.Utils.Exception
    import GHC.Utils.Error
    import GHC.Utils.Logger

    import System.Directory
    import System.FilePath
    import System.IO
    import System.IO.Error  ( isEOFError )
    import Control.Monad    ( when, forM_ )
    import Data.Maybe       ( isJust )
    import Data.IORef
    import qualified Data.Set as Set

    -----------------------------------------------------------------
    --
    --              The main function
    --
    -----------------------------------------------------------------

    doMkDependHS :: GhcMonad m => [FilePath] -> m ()
    doMkDependHS srcs = do
        logger <- getLogger

        -- Initialisation
        dflags0 <- GHC.getSessionDynFlags

        -- We kludge things a bit for dependency generation. Rather than
        -- generating dependencies for each way separately, we generate
        -- them once and then duplicate them for each way's osuf/hisuf.
        -- We therefore do the initial dependency generation with an empty
        -- way and .o/.hi extensions, regardless of any flags that might
        -- be specified.
        let dflags = dflags0
                { targetWays_ = Set.empty
                , hiSuf_      = "hi"
                , objectSuf_  = "o"
                }
        GHC.setSessionDynFlags dflags

        when (null (depSuffixes dflags)) $ liftIO $
            throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix")

        tmpfs <- hsc_tmpfs <$> getSession
        files <- liftIO $ beginMkDependHS logger tmpfs dflags

        -- Do the downsweep to find all the modules
        targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs
        GHC.setTargets targets
        let excl_mods = depExcludeMods dflags
        module_graph <- GHC.depanal excl_mods True {- Allow dup roots -}

        -- Sort into dependency order
        -- There should be no cycles
        let sorted = GHC.topSortModuleGraph False module_graph Nothing

        -- Print out the dependencies if wanted
        liftIO $ debugTraceMsg logger dflags 2 (text "Module dependencies" $$ ppr sorted)

        -- Process them one by one, dumping results into makefile
        -- and complaining about cycles
        hsc_env <- getSession
        root <- liftIO getCurrentDirectory
        mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted

        -- If -ddump-mod-cycles, show cycles in the module graph
        liftIO $ dumpModCycles logger dflags module_graph

        -- Tidy up
        liftIO $ endMkDependHS logger dflags files

        -- Unconditional exiting is a bad idea.  If an error occurs we'll get an
        --exception; if that is not caught it's fine, but at least we have a
        --chance to find out exactly what went wrong.  Uncomment the following
        --line if you disagree.

        --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1)

    -----------------------------------------------------------------
    --
    --              beginMkDependHs
    --      Create a temporary file,
    --      find the Makefile,
    --      slurp through it, etc
    --
    -----------------------------------------------------------------

    data MkDepFiles
      = MkDep { mkd_make_file :: FilePath,          -- Name of the makefile
                mkd_make_hdl  :: Maybe Handle,      -- Handle for the open makefile
                mkd_tmp_file  :: FilePath,          -- Name of the temporary file
                mkd_tmp_hdl   :: Handle }           -- Handle of the open temporary file

    beginMkDependHS :: Logger -> TmpFs -> DynFlags -> IO MkDepFiles
    beginMkDependHS logger tmpfs dflags = do
            -- open a new temp file in which to stuff the dependency info
            -- as we go along.
      tmp_file <- newTempName logger tmpfs dflags TFL_CurrentModule "dep"
      tmp_hdl <- openFile tmp_file WriteMode

            -- open the makefile
      let makefile = depMakefile dflags
      exists <- doesFileExist makefile
      mb_make_hdl <-
            if not exists
            then return Nothing
            else do
               makefile_hdl <- openFile makefile ReadMode

                    -- slurp through until we get the magic start string,
                    -- copying the contents into dep_makefile
               let slurp = do
                    l <- hGetLine makefile_hdl
                    if (l == depStartMarker)
                            then return ()
                            else do hPutStrLn tmp_hdl l; slurp

                    -- slurp through until we get the magic end marker,
                    -- throwing away the contents
               let chuck = do
                    l <- hGetLine makefile_hdl
                    if (l == depEndMarker)
                            then return ()
                            else chuck

               catchIO slurp
                    (\e -> if isEOFError e then return () else ioError e)
               catchIO chuck
                    (\e -> if isEOFError e then return () else ioError e)

               return (Just makefile_hdl)

            -- write the magic marker into the tmp file
      hPutStrLn tmp_hdl depStartMarker

      return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl,
                      mkd_tmp_file  = tmp_file, mkd_tmp_hdl  = tmp_hdl})

    -----------------------------------------------------------------
    --
    --              processDeps
    --
    -----------------------------------------------------------------

    processDeps :: DynFlags
                -> HscEnv
                -> [ModuleName]
                -> FilePath
                -> Handle           -- Write dependencies to here
                -> SCC ModuleGraphNode
                -> IO ()
    -- Write suitable dependencies to handle
    -- Always:
    --                      this.o : this.hs
    --
    -- If the dependency is on something other than a .hi file:
    --                      this.o this.p_o ... : dep
    -- otherwise
    --                      this.o ...   : dep.hi
    --                      this.p_o ... : dep.p_hi
    --                      ...
    -- (where .o is $osuf, and the other suffixes come from
    -- the cmdline -s options).
    --
    -- For {-# SOURCE #-} imports the "hi" will be "hi-boot".

    processDeps dflags _ _ _ _ (CyclicSCC nodes)
      =     -- There shouldn't be any cycles; report them
        throwGhcExceptionIO $ ProgramError $
          showSDoc dflags $ GHC.cyclicModuleErr nodes

    processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode node))
      =     -- There shouldn't be any backpack instantiations; report them as well
        throwGhcExceptionIO $ ProgramError $
          showSDoc dflags $
            vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:"
                 , nest 2 $ ppr node ]

    processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode (ExtendedModSummary node _)))
      = do  { let extra_suffixes = depSuffixes dflags
                  include_pkg_deps = depIncludePkgDeps dflags
                  src_file  = msHsFilePath node
                  obj_file  = msObjFilePath node
                  obj_files = insertSuffixes obj_file extra_suffixes

                  do_imp loc is_boot pkg_qual imp_mod
                    = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod
                                                   is_boot include_pkg_deps
                         ; case mb_hi of {
                               Nothing      -> return () ;
                               Just hi_file -> do
                         { let hi_files = insertSuffixes hi_file extra_suffixes
                               write_dep (obj,hi) = writeDependency root hdl [obj] hi

                            -- Add one dependency for each suffix;
                            -- e.g.         A.o   : B.hi
                            --              A.x_o : B.x_hi
                         ; mapM_ write_dep (obj_files `zip` hi_files) }}}

                    -- Emit std dependency of the object(s) on the source file
                    -- Something like       A.o : A.hs
            ; writeDependency root hdl obj_files src_file

              -- add dependency between objects and their corresponding .hi-boot
              -- files if the module has a corresponding .hs-boot file (#14482)
            ; when (isBootSummary node == IsBoot) $ do
                let hi_boot = msHiFilePath node
                let obj     = removeBootSuffix (msObjFilePath node)
                forM_ extra_suffixes $ \suff -> do
                   let way_obj     = insertSuffixes obj     [suff]
                   let way_hi_boot = insertSuffixes hi_boot [suff]
                   mapM_ (writeDependency root hdl way_obj) way_hi_boot

                    -- Emit a dependency for each CPP import
            ; when (depIncludeCppDeps dflags) $ do
                -- CPP deps are descovered in the module parsing phase by parsing
                -- comment lines left by the preprocessor.
                -- Note that GHC.parseModule may throw an exception if the module
                -- fails to parse, which may not be desirable (see #16616).
              { session <- Session <$> newIORef hsc_env
              ; parsedMod <- reflectGhc (GHC.parseModule node) session
              ; mapM_ (writeDependency root hdl obj_files)
                      (GHC.pm_extra_src_files parsedMod)
              }

                    -- Emit a dependency for each import

            ; let do_imps is_boot idecls = sequence_
                        [ do_imp loc is_boot mb_pkg mod
                        | (mb_pkg, L loc mod) <- idecls,
                          mod `notElem` excl_mods ]

            ; do_imps IsBoot (ms_srcimps node)
            ; do_imps NotBoot (ms_imps node)
            }

    findDependency  :: HscEnv
                    -> SrcSpan
                    -> Maybe FastString     -- package qualifier, if any
                    -> ModuleName           -- Imported module
                    -> IsBootInterface      -- Source import
                    -> Bool                 -- Record dependency on package modules
                    -> IO (Maybe FilePath)  -- Interface file
    findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps
      = do  {       -- Find the module; this will be fast because
                    -- we've done it once during downsweep
              r <- findImportedModule hsc_env imp pkg
            ; case r of
                Found loc _
                    -- Home package: just depend on the .hi or hi-boot file
                    | isJust (ml_hs_file loc) || include_pkg_deps
                    -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))

                    -- Not in this package: we don't need a dependency
                    | otherwise
                    -> return Nothing

                fail ->
                    throwOneError $ mkPlainMsgEnvelope srcloc $
                         cannotFindModule hsc_env imp fail
            }

    -----------------------------
    writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
    -- (writeDependency r h [t1,t2] dep) writes to handle h the dependency
    --      t1 t2 : dep
    writeDependency root hdl targets dep
      = do let -- We need to avoid making deps on
               --     c:/foo/...
               -- on cygwin as make gets confused by the :
               -- Making relative deps avoids some instances of this.
               dep' = makeRelative root dep
               forOutput = escapeSpaces . reslash Forwards . normalise
               output = unwords (map forOutput targets) ++ " : " ++ forOutput dep'
           hPutStrLn hdl output

    -----------------------------
    insertSuffixes
            :: FilePath     -- Original filename;   e.g. "foo.o"
            -> [String]     -- Suffix prefixes      e.g. ["x_", "y_"]
            -> [FilePath]   -- Zapped filenames     e.g. ["foo.x_o", "foo.y_o"]
            -- Note that the extra bit gets inserted *before* the old suffix
            -- We assume the old suffix contains no dots, so we know where to
            -- split it
    insertSuffixes file_name extras
      = [ basename <.> (extra ++ suffix) | extra <- extras ]
      where
        (basename, suffix) = case splitExtension file_name of
                             -- Drop the "." from the extension
                             (b, s) -> (b, drop 1 s)

    -----------------------------------------------------------------
    --
    --              endMkDependHs
    --      Complete the makefile, close the tmp file etc
    --
    -----------------------------------------------------------------

    endMkDependHS :: Logger -> DynFlags -> MkDepFiles -> IO ()

    endMkDependHS logger dflags
       (MkDep { mkd_make_file = makefile, mkd_make_hdl =  makefile_hdl,
                mkd_tmp_file  = tmp_file, mkd_tmp_hdl  =  tmp_hdl })
      = do
      -- write the magic marker into the tmp file
      hPutStrLn tmp_hdl depEndMarker

      case makefile_hdl of
         Nothing  -> return ()
         Just hdl -> do

              -- slurp the rest of the original makefile and copy it into the output
            let slurp = do
                    l <- hGetLine hdl
                    hPutStrLn tmp_hdl l
                    slurp

            catchIO slurp
                    (\e -> if isEOFError e then return () else ioError e)

            hClose hdl

      hClose tmp_hdl  -- make sure it's flushed

            -- Create a backup of the original makefile
      when (isJust makefile_hdl)
           (SysTools.copy logger dflags ("Backing up " ++ makefile)
              makefile (makefile++".bak"))

            -- Copy the new makefile in place
      SysTools.copy logger dflags "Installing new makefile" tmp_file makefile

    -----------------------------------------------------------------
    --              Module cycles
    -----------------------------------------------------------------

    dumpModCycles :: Logger -> DynFlags -> ModuleGraph -> IO ()
    dumpModCycles logger dflags module_graph
      | not (dopt Opt_D_dump_mod_cycles dflags)
      = return ()

      | null cycles
      = putMsg logger dflags (text "No module cycles")

      | otherwise
      = putMsg logger dflags (hang (text "Module cycles found:") 2 pp_cycles)
      where
        topoSort = filterToposortToModules $
          GHC.topSortModuleGraph True module_graph Nothing

        cycles :: [[ModSummary]]
        cycles =
          [ c | CyclicSCC c <- topoSort ]

        pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> ptext (sLit "----------"))
                            $$ pprCycle c $$ blankLine
                         | (n,c) <- [1..] `zip` cycles ]

    pprCycle :: [ModSummary] -> SDoc
    -- Print a cycle, but show only the imports within the cycle
    pprCycle summaries = pp_group (CyclicSCC summaries)
      where
        cycle_mods :: [ModuleName]  -- The modules in this cycle
        cycle_mods = map (moduleName . ms_mod) summaries

        pp_group (AcyclicSCC ms) = pp_ms ms
        pp_group (CyclicSCC mss)
            = ASSERT( not (null boot_only) )
                    -- The boot-only list must be non-empty, else there would
                    -- be an infinite chain of non-boot imports, and we've
                    -- already checked for that in processModDeps
              pp_ms loop_breaker $$ vcat (map pp_group groups)
            where
              (boot_only, others) = partition is_boot_only mss
              is_boot_only ms = not (any in_group (map snd (ms_imps ms)))
              in_group (L _ m) = m `elem` group_mods
              group_mods = map (moduleName . ms_mod) mss

              loop_breaker = head boot_only
              all_others   = tail boot_only ++ others
              groups = filterToposortToModules $
                GHC.topSortModuleGraph True (mkModuleGraph $ extendModSummaryNoDeps <$> all_others) Nothing

        pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))
                           <+> (pp_imps empty (map snd (ms_imps summary)) $$
                                pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary)))
            where
              mod_str = moduleNameString (moduleName (ms_mod summary))

        pp_imps :: SDoc -> [Located ModuleName] -> SDoc
        pp_imps _    [] = empty
        pp_imps what lms
            = case [m | L _ m <- lms, m `elem` cycle_mods] of
                [] -> empty
                ms -> what <+> text "imports" <+>
                                    pprWithCommas ppr ms

    -----------------------------------------------------------------
    --
    --              Flags
    --
    -----------------------------------------------------------------

    depStartMarker, depEndMarker :: String
    depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
    depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"