Torsten Schmits pushed to branch wip/torsten.schmits/mwb-26-01/fixed at Glasgow Haskell Compiler / GHC

Commits:

10 changed files:

Changes:

  • compiler/GHC.hs
    ... ... @@ -75,9 +75,12 @@ module GHC (
    75 75 
             compileToCoreModule, compileToCoreSimplified,
    76 76
    77 77 
             -- * Inspecting the module structure of the program
    78 
    -        ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,
    79 
    -        mgLookupModule,
    78 
    +        ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries, mgModSummaries',
    79 
    +        mgLookupModule, mgNodeIsModule,
    80 80 
             ModSummary(..), ms_mod_name, ModLocation(..),
    81 
    +        ModuleNodeInfo(..), moduleNodeInfoModule, moduleNodeInfoModuleName,
    82 
    +        moduleNodeInfoLocation, moduleNodeInfoHscSource,
    83 
    +        isBootModuleNodeInfo,
    81 84 
             pattern ModLocation,
    82 85 
             getModSummary,
    83 86 
             getModuleGraph,

  • compiler/GHC/Driver/Backpack.hs
    ... ... @@ -748,9 +748,9 @@ hsunitModuleGraph do_link unit = do
    748 748 
         --  create an "empty" hsig file to induce compilation for the
    749 749 
         --  requirement.
    750 750 
         let hsig_set = Set.fromList
    751 
    -          [ ms_mod_name ms
    751 
    +          [ moduleNodeInfoModuleName ms
    752 752 
               | ModuleNode _ ms <- nodes
    753 
    -          , ms_hsc_src ms == HsigFile
    753 
    +          , moduleNodeInfoHscSource ms == Just HsigFile
    754 754 
               ]
    755 755 
         req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) ->
    756 756 
             if Set.member mod_name hsig_set
    ... ... @@ -825,7 +825,7 @@ summariseRequirement pn mod_name = do
    825 825 
             ms_hspp_buf = Nothing
    826 826 
             }
    827 827 
         let nodes = [NodeKey_Module (ModNodeKeyWithUid (GWIB mn NotBoot) (homeUnitId home_unit)) | mn <- extra_sig_imports ]
    828 
    -    return (ModuleNode nodes ms)
    828 
    +    return (ModuleNode nodes (ModuleNodeCompile ms))
    829 829
    830 830 
     summariseDecl :: PackageName
    831 831 
                   -> HscSource
    ... ... @@ -943,7 +943,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
    943 943 
               [k | (_, mnwib) <- msDeps ms, let k = NodeKey_Module (ModNodeKeyWithUid (fmap unLoc mnwib) (moduleUnitId this_mod)), k `elem` home_keys]
    944 944
    945 945
    946 
    -    return (ModuleNode (mod_nodes ++ inst_nodes) ms)
    946 
    +    return (ModuleNode (mod_nodes ++ inst_nodes) (ModuleNodeCompile ms))
    947 947
    948 948 
     -- | Create a new, externally provided hashed unit id from
    949 949 
     -- a hash.

  • compiler/GHC/Driver/Main.hs
    ... ... @@ -50,6 +50,7 @@ module GHC.Driver.Main
    50 50 
         , initModDetails
    51 51 
         , initWholeCoreBindings
    52 52 
         , loadIfaceByteCode
    53 
    +    , loadIfaceByteCodeLazy
    53 54 
         , hscMaybeWriteIface
    54 55 
         , hscCompileCmmFile
    55 56
    ... ... @@ -106,6 +107,7 @@ module GHC.Driver.Main
    106 107 
         , hscAddSptEntries
    107 108 
         , writeInterfaceOnlyMode
    108 109 
         , loadByteCode
    110 
    +    , genModDetails
    109 111 
         ) where
    110 112
    111 113 
     import GHC.Prelude
    ... ... @@ -824,7 +826,7 @@ hscRecompStatus
    824 826 
       = do
    825 827 
         let
    826 828 
             msg what = case mHscMessage of
    827 
    -          Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] mod_summary)
    829 
    +          Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] (ModuleNodeCompile mod_summary))
    828 830 
               Nothing -> return ()
    829 831
    830 832 
         -- First check to see if the interface file agrees with the
    ... ... @@ -1055,6 +1057,27 @@ loadIfaceByteCode hsc_env iface location type_env =
    1055 1057 
           time <- maybe getCurrentTime pure if_time
    1056 1058 
           return $! Linkable time (mi_module iface) parts
    1057 1059
    1060 
    +loadIfaceByteCodeLazy ::
    1061 
    +  HscEnv ->
    1062 
    +  ModIface ->
    1063 
    +  ModLocation ->
    1064 
    +  TypeEnv ->
    1065 
    +  IO (Maybe Linkable)
    1066 
    +loadIfaceByteCodeLazy hsc_env iface location type_env =
    1067 
    +  case iface_core_bindings iface location of
    1068 
    +    Nothing -> return Nothing
    1069 
    +    Just wcb -> do
    1070 
    +      Just <$> compile wcb
    1071 
    +  where
    1072 
    +    compile decls = do
    1073 
    +      ~(bcos, fos) <- unsafeInterleaveIO $ compileWholeCoreBindings hsc_env type_env decls
    1074 
    +      linkable $ BCOs bcos :| [DotO fo ForeignObject | fo <- fos]
    1075 
    +
    1076 
    +    linkable parts = do
    1077 
    +      if_time <- modificationTimeIfExists (ml_hi_file location)
    1078 
    +      time <- maybe getCurrentTime pure if_time
    1079 
    +      return $!Linkable time (mi_module iface) parts
    1080 
    +
    1058 1081 
     -- | If the 'Linkable' contains Core bindings loaded from an interface, replace
    1059 1082 
     -- them with a lazy IO thunk that compiles them to bytecode and foreign objects,
    1060 1083 
     -- using the supplied environment for type checking.

  • compiler/GHC/Driver/Make.hs
    ... ... @@ -43,115 +43,108 @@ module GHC.Driver.Make (
    43 43 
             ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert, modNodeMapSingleton, modNodeMapUnionWith
    44 44 
             ) where
    45 45
    46 
    -import GHC.Prelude
    47 
    -import GHC.Platform
    48 
    -
    49 
    -import GHC.Tc.Utils.Backpack
    50 
    -import GHC.Tc.Utils.Monad  ( initIfaceCheck, concatMapM )
    51 
    -
    52 
    -import GHC.Runtime.Interpreter
    53 
    -import qualified GHC.Linker.Loader as Linker
    54 
    -import GHC.Linker.Types
    55 
    -
    56 
    -import GHC.Platform.Ways
    57 
    -
    58 
    -import GHC.Driver.Config.Finder (initFinderOpts)
    59 
    -import GHC.Driver.Config.Parser (initParserOpts)
    60 
    -import GHC.Driver.Config.Diagnostic
    61 
    -import GHC.Driver.Phases
    62 
    -import GHC.Driver.Pipeline
    63 
    -import GHC.Driver.Session
    64 
    -import GHC.Driver.Backend
    65 
    -import GHC.Driver.Monad
    66 
    -import GHC.Driver.Env
    67 
    -import GHC.Driver.Errors
    68 
    -import GHC.Driver.Errors.Types
    69 
    -import GHC.Driver.Main
    70 
    -import GHC.Driver.MakeSem
    71 
    -
    72 
    -import GHC.Parser.Header
    46 
    +import Control.Concurrent (
    47 
    +  ThreadId,
    48 
    +  forkIOWithUnmask,
    49 
    +  killThread,
    50 
    +  newQSem,
    51 
    +  signalQSem,
    52 
    +  waitQSem,
    53 
    +  )
    54 
    +import Control.Concurrent.MVar
    55 
    +import Control.Concurrent.STM
    56 
    +import Control.Monad
    57 
    +import qualified Control.Monad.Catch as MC
    58 
    +import Control.Monad.IO.Class
    59 
    +import Control.Monad.Trans.Class
    60 
    +import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE)
    61 
    +import Control.Monad.Trans.Maybe
    62 
    +import Control.Monad.Trans.Reader
    63 
    +import Control.Monad.Trans.State.Lazy
    64 
    +import Data.Bifunctor (first)
    65 
    +import Data.Either (lefts, partitionEithers, rights)
    66 
    +import Data.Function
    67 
    +import Data.IORef
    68 
    +import Data.List (groupBy, sortBy, sortOn, unfoldr)
    69 
    +import qualified Data.Map as Map
    70 
    +import qualified Data.Map.Strict as M
    71 
    +import Data.Maybe
    72 
    +import qualified Data.Set as Set
    73 
    +import Data.Time
    73 74 
     import GHC.ByteCode.Types
    74 
    -
    75 
    -import GHC.Iface.Load      ( cannotFindModule )
    76 
    -import GHC.IfaceToCore     ( typecheckIface )
    77 
    -import GHC.Iface.Recomp    ( RecompileRequired(..), CompileReason(..) )
    78 
    -
    79 
    -import GHC.Data.Bag        ( listToBag )
    80 
    -import GHC.Data.Graph.Directed
    75 
    +import qualified GHC.Conc as CC
    76 
    +import GHC.Conc (getNumCapabilities, getNumProcessors, setNumCapabilities)
    77 
    +import GHC.Data.Bag (listToBag)
    81 78 
     import GHC.Data.FastString
    82 
    -import GHC.Data.Maybe      ( expectJust )
    83 
    -import GHC.Data.OsPath     ( unsafeEncodeUtf )
    79 
    +import GHC.Data.Graph.Directed
    80 
    +import GHC.Data.Graph.Directed.Reachability
    81 
    +import qualified GHC.Data.Maybe as MB
    82 
    +import GHC.Data.Maybe (expectJust)
    83 
    +import qualified GHC.Data.OsPath as OsPath
    84 
    +import GHC.Data.OsPath (OsPath, unsafeEncodeUtf)
    84 85 
     import GHC.Data.StringBuffer
    86 
    +import GHC.Iface.Errors.Types
    87 
    +import GHC.Iface.Load (cannotFindModule, readIface)
    88 
    +import GHC.Iface.Recomp (CompileReason (..), RecompileRequired (..))
    89 
    +import GHC.IfaceToCore (typecheckIface)
    85 90 
     import qualified GHC.LanguageExtensions as LangExt
    86 
    -
    87 
    -import GHC.Utils.Exception ( throwIO, SomeAsyncException )
    88 
    -import GHC.Utils.Outputable
    89 
    -import GHC.Utils.Panic
    90 
    -import GHC.Utils.Misc
    91 
    -import GHC.Utils.Error
    92 
    -import GHC.Utils.Logger
    93 
    -import GHC.Utils.Fingerprint
    94 
    -import GHC.Utils.TmpFs
    95 
    -
    91 
    +import qualified GHC.Linker.Loader as Linker
    92 
    +import GHC.Linker.Types
    93 
    +import GHC.Parser.Header
    94 
    +import GHC.Platform
    95 
    +import GHC.Platform.Ways
    96 
    +import GHC.Prelude
    97 
    +import GHC.Rename.Names
    98 
    +import GHC.Runtime.Interpreter
    99 
    +import GHC.Runtime.Loader
    100 
    +import GHC.Tc.Utils.Backpack
    101 
    +import GHC.Tc.Utils.Monad (concatMapM, initIfaceCheck)
    96 102 
     import GHC.Types.Basic
    97 103 
     import GHC.Types.Error
    98 
    -import GHC.Types.Target
    99 
    -import GHC.Types.SourceFile
    104 
    +import GHC.Types.PkgQual
    100 105 
     import GHC.Types.SourceError
    106 
    +import GHC.Types.SourceFile
    101 107 
     import GHC.Types.SrcLoc
    108 
    +import GHC.Types.Target
    109 
    +import GHC.Types.TypeEnv
    102 110 
     import GHC.Types.Unique.Map
    103 
    -import GHC.Types.PkgQual
    104 
    -
    105 111 
     import GHC.Unit
    106 112 
     import GHC.Unit.Env
    107 113 
     import GHC.Unit.Finder
    108 
    -import GHC.Unit.Module.ModSummary
    109 
    -import GHC.Unit.Module.ModIface
    110 
    -import GHC.Unit.Module.Graph
    114 
    +import qualified GHC.Unit.Home.Graph as HUG
    111 115 
     import GHC.Unit.Home.ModInfo
    116 
    +import GHC.Unit.Home.PackageTable
    117 
    +import GHC.Unit.Module.Graph
    112 118 
     import GHC.Unit.Module.ModDetails
    113 
    -
    114 
    -import Data.Either ( rights, partitionEithers, lefts )
    115 
    -import qualified Data.Map as Map
    116 
    -import qualified Data.Set as Set
    117 
    -
    118 
    -import GHC.Data.OsPath (OsPath)
    119 
    -import qualified GHC.Data.OsPath as OsPath
    120 
    -import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )
    121 
    -import qualified GHC.Conc as CC
    122 
    -import Control.Concurrent.MVar
    123 
    -import Control.Monad
    124 
    -import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
    125 
    -import qualified Control.Monad.Catch as MC
    126 
    -import Data.IORef
    127 
    -import Data.Maybe
    128 
    -import Data.Time
    129 
    -import Data.List (sortOn, unfoldr)
    130 
    -import Data.List (sortOn, unfoldr, groupBy, sortBy)
    131 
    -import Data.Bifunctor (first)
    119 
    +import GHC.Unit.Module.ModIface
    120 
    +import GHC.Unit.Module.ModSummary
    121 
    +import GHC.Utils.Constants
    122 
    +import GHC.Utils.Error
    123 
    +import GHC.Utils.Exception (SomeAsyncException, throwIO)
    124 
    +import GHC.Utils.Fingerprint
    125 
    +import GHC.Utils.Logger
    126 
    +import GHC.Utils.Misc
    127 
    +import GHC.Utils.Outputable
    128 
    +import GHC.Utils.Panic
    129 
    +import GHC.Utils.TmpFs
    132 130 
     import System.Directory
    133 131 
     import System.FilePath
    134 132
    135 
    -import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )
    136 
    -import Control.Monad.IO.Class
    137 
    -import Control.Monad.Trans.Reader
    138 
    -import GHC.Driver.Pipeline.LogQueue
    139 
    -import qualified Data.Map.Strict as M
    140 
    -import GHC.Types.TypeEnv
    141 
    -import Control.Monad.Trans.State.Lazy
    142 
    -import Control.Monad.Trans.Class
    133 
    +import GHC.Driver.Backend
    134 
    +import GHC.Driver.Config.Diagnostic
    135 
    +import GHC.Driver.Config.Finder (initFinderOpts)
    136 
    +import GHC.Driver.Config.Parser (initParserOpts)
    137 
    +import GHC.Driver.Env
    143 138 
     import GHC.Driver.Env.KnotVars
    144 
    -import Control.Concurrent.STM
    145 
    -import Control.Monad.Trans.Maybe
    146 
    -import GHC.Runtime.Loader
    147 
    -import GHC.Rename.Names
    148 
    -import GHC.Utils.Constants
    149 
    -import GHC.Iface.Errors.Types
    150 
    -import Data.Function
    151 
    -
    152 
    -import GHC.Data.Graph.Directed.Reachability
    153 
    -import qualified GHC.Unit.Home.Graph as HUG
    154 
    -import GHC.Unit.Home.PackageTable
    139 
    +import GHC.Driver.Errors
    140 
    +import GHC.Driver.Errors.Types
    141 
    +import GHC.Driver.Main
    142 
    +import GHC.Driver.MakeSem
    143 
    +import GHC.Driver.Monad
    144 
    +import GHC.Driver.Phases
    145 
    +import GHC.Driver.Pipeline
    146 
    +import GHC.Driver.Pipeline.LogQueue
    147 
    +import GHC.Driver.Session
    155 148
    156 149 
     -- -----------------------------------------------------------------------------
    157 150 
     -- Loading the program
    ... ... @@ -628,13 +621,16 @@ createBuildPlan mod_graph maybe_top_mod =
    628 621
    629 622 
             -- An environment mapping a module to its hs-boot file and all nodes on the path between the two, if one exists
    630 623 
             boot_modules = mkModuleEnv
    631 
    -          [ (ms_mod ms, (m, boot_path (ms_mod_name ms) (ms_unitid ms))) | m@(ModuleNode _ ms) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot]
    624 
    +          [ (mn, (m, boot_path (moduleName mn) (moduleUnitId mn)))
    625 
    +            | m@(ModuleNode _ ms) <- (mgModSummaries' mod_graph)
    626 
    +            , let mn = moduleNodeInfoModule ms
    627 
    +            , isBootModuleNodeInfo ms == IsBoot]
    632 628
    633 629 
             select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]
    634 630 
             select_boot_modules = mapMaybe (fmap fst . get_boot_module)
    635 631
    636 632 
             get_boot_module :: ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])
    637 
    -        get_boot_module m = case m of ModuleNode _ ms | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing
    633 
    +        get_boot_module m = case m of ModuleNode _ ms | NotBoot <- isBootModuleNodeInfo ms -> lookupModuleEnv boot_modules (moduleNodeInfoModule ms); _ -> Nothing
    638 634
    639 635 
             -- Any cycles should be resolved now
    640 636 
             collapseSCC :: [SCC ModuleGraphNode] -> Either [ModuleGraphNode] [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]
    ... ... @@ -760,7 +756,7 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do
    760 756 
             -- prune the HPT so everything is not retained when doing an
    761 757 
             -- upsweep.
    762 758 
             !pruned_cache = pruneCache cache
    763 
    -                            (flattenSCCs (filterToposortToModules  mg2_with_srcimps))
    759 
    +                            [ms | (ModuleNodeCompile ms) <- (flattenSCCs (filterToposortToModules  mg2_with_srcimps))]
    764 760
    765 761
    766 762 
         -- before we unload anything, make sure we don't leave an old
    ... ... @@ -820,7 +816,7 @@ guessOutputFile = modifySession $ \env ->
    820 816 
                     mainModuleSrcPath :: Maybe String
    821 817 
                     mainModuleSrcPath = do
    822 818 
                       ms <- mgLookupModule mod_graph (mainModIs hue)
    823 
    -                  ml_hs_file (ms_location ms)
    819 
    +                  ml_hs_file (moduleNodeInfoLocation ms)
    824 820 
                     name = fmap dropExtension mainModuleSrcPath
    825 821
    826 822 
                     -- MP: This exception is quite sensitive to being forced, if you
    ... ... @@ -1153,7 +1149,7 @@ interpretBuildPlan hug mhmi_cache old_hpt plan = do
    1153 1149 
                       executeInstantiationNode mod_idx n_mods hug uid iu
    1154 1150 
                       return Nothing
    1155 1151 
                   ModuleNode _build_deps ms ->
    1156 
    -                let !old_hmi = M.lookup (msKey ms) old_hpt
    1152 
    +                let !old_hmi = M.lookup (mnKey ms) old_hpt
    1157 1153 
                         rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes
    1158 1154 
                     in withCurrentUnit (moduleGraphNodeUnitId mod) $ do
    1159 1155 
                          !_ <- wait_deps build_deps
    ... ... @@ -1523,13 +1519,13 @@ modNodeMapUnionWith f (ModNodeMap m) (ModNodeMap n) = ModNodeMap (M.unionWith f
    1523 1519 
     -- components in the topological sort, then those imports can
    1524 1520 
     -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
    1525 1521 
     -- were necessary, then the edge would be part of a cycle.
    1526 
    -warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
    1522 
    +warnUnnecessarySourceImports :: GhcMonad m => [SCC ModuleNodeInfo] -> m ()
    1527 1523 
     warnUnnecessarySourceImports sccs = do
    1528 1524 
       diag_opts <- initDiagOpts <$> getDynFlags
    1529 1525 
       when (diag_wopt Opt_WarnUnusedImports diag_opts) $ do
    1530 1526 
         let check ms =
    1531 
    -           let mods_in_this_cycle = map ms_mod_name ms in
    1532 
    -           [ warn i | m <- ms, i <- ms_home_srcimps m,
    1527 
    +           let mods_in_this_cycle = map moduleNodeInfoModuleName ms in
    1528 
    +           [ warn i | (ModuleNodeCompile m) <- ms, i <- ms_home_srcimps m,
    1533 1529 
                           unLoc i `notElem`  mods_in_this_cycle ]
    1534 1530
    1535 1531 
             warn :: Located ModuleName -> MsgEnvelope GhcMessage
    ... ... @@ -1670,7 +1666,7 @@ downsweep_imports hsc_env old_summaries old_graph excl_mods allow_dup_roots (roo
    1670 1666 
                  (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised
    1671 1667 
                  -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
    1672 1668 
                  (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'
    1673 
    -             loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', summarised'')
    1669 
    +             loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'')
    1674 1670 
               where
    1675 1671 
                 k = NodeKey_Module (msKey ms)
    1676 1672
    ... ... @@ -1904,7 +1900,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
    1904 1900 
       where
    1905 1901 
         defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env)
    1906 1902 
         enable_code_gen :: ModuleGraphNode -> IO ModuleGraphNode
    1907 
    -    enable_code_gen n@(ModuleNode deps ms)
    1903 
    +    enable_code_gen n@(ModuleNode deps (ModuleNodeCompile ms))
    1908 1904 
           | ModSummary
    1909 1905 
             { ms_location = ms_location
    1910 1906 
             , ms_hsc_src = HsSrcFile
    ... ... @@ -1942,7 +1938,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
    1942 1938 
                          , ms_hspp_opts = updOptLevel 0 $ new_dflags
    1943 1939 
                          }
    1944 1940 
                    -- Recursive call to catch the other cases
    1945 
    -               enable_code_gen (ModuleNode deps ms')
    1941 
    +               enable_code_gen (ModuleNode deps (ModuleNodeCompile ms'))
    1946 1942
    1947 1943 
              -- If -fprefer-byte-code then satisfy dependency by enabling bytecode (if normal object not enough)
    1948 1944 
              -- we only get to this case if the default backend is already generating object files, but we need dynamic
    ... ... @@ -1952,19 +1948,19 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
    1952 1948 
                          { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ByteCodeAndObjectCode
    1953 1949 
                          }
    1954 1950 
                    -- Recursive call to catch the other cases
    1955 
    -               enable_code_gen (ModuleNode deps ms')
    1951 
    +               enable_code_gen (ModuleNode deps (ModuleNodeCompile ms'))
    1956 1952 
              | dynamic_too_enable enable_spec ms -> do
    1957 1953 
                    let ms' = ms
    1958 1954 
                          { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_BuildDynamicToo
    1959 1955 
                          }
    1960 1956 
                    -- Recursive call to catch the other cases
    1961 
    -               enable_code_gen (ModuleNode deps ms')
    1957 
    +               enable_code_gen (ModuleNode deps (ModuleNodeCompile ms'))
    1962 1958 
              | ext_interp_enable ms -> do
    1963 1959 
                    let ms' = ms
    1964 1960 
                          { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ExternalInterpreter
    1965 1961 
                          }
    1966 1962 
                    -- Recursive call to catch the other cases
    1967 
    -               enable_code_gen (ModuleNode deps ms')
    1963 
    +               enable_code_gen (ModuleNode deps (ModuleNodeCompile ms'))
    1968 1964
    1969 1965 
              | otherwise -> return n
    1970 1966
    ... ... @@ -2043,7 +2039,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
    2043 2039 
             -- Note we don't need object code for a module if it uses TemplateHaskell itself. Only
    2044 2040 
             -- it's dependencies.
    2045 2041 
             [ deps
    2046 
    -        | (ModuleNode deps ms) <- mod_graph
    2042 
    +        | (ModuleNode deps (ModuleNodeCompile ms)) <- mod_graph
    2047 2043 
             , isTemplateHaskellOrQQNonBoot ms
    2048 2044 
             , not (gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms))
    2049 2045 
             ]
    ... ... @@ -2052,7 +2048,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
    2052 2048 
         need_bc_set =
    2053 2049 
           concat
    2054 2050 
             [ deps
    2055 
    -        | (ModuleNode deps ms) <- mod_graph
    2051 
    +        | (ModuleNode deps (ModuleNodeCompile ms)) <- mod_graph
    2056 2052 
             , isTemplateHaskellOrQQNonBoot ms
    2057 2053 
             , gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms)
    2058 2054 
             ]
    ... ... @@ -2514,9 +2510,14 @@ cyclicModuleErr mss
    2514 2510 
         ppr_node (InstantiationNode _uid u) = text "instantiated unit" <+> ppr u
    2515 2511 
         ppr_node (LinkNode uid _) = pprPanic "LinkNode should not be in a cycle" (ppr uid)
    2516 2512
    2517 
    -    ppr_ms :: ModSummary -> SDoc
    2518 
    -    ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>
    2519 
    -                (parens (text (msHsFilePath ms)))
    2513 
    +    ppr_ms :: ModuleNodeInfo -> SDoc
    2514 
    +    ppr_ms ms = quotes (ppr (moduleNodeInfoModule ms)) <+>
    2515 
    +                (parens (text (node_path ms)))
    2516 
    +
    2517 
    +    node_path :: ModuleNodeInfo -> FilePath
    2518 
    +    node_path ms = case ml_hs_file (moduleNodeInfoLocation ms) of
    2519 
    +      Just f -> f
    2520 
    +      Nothing -> ml_hi_file (moduleNodeInfoLocation ms)
    2520 2521
    2521 2522
    2522 2523 
     cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m ()
    ... ... @@ -2609,39 +2610,72 @@ executeInstantiationNode k n deps uid iu = do
    2609 2610 
                 return res
    2610 2611
    2611 2612
    2613 
    +-- | executeCompileNode interprets how --make module should compile a ModuleNode
    2614 
    +--
    2615 
    +-- 1. If the ModuleNode is a ModuleNodeCompile, then we first check
    2616 
    +--    if the interface file exists and is up to date. If it is, we return those.
    2617 
    +--    Otherwise, we compile the module and return the new HomeModInfo.
    2618 
    +-- 2. If the ModuleNode is a ModuleNodeFixed, then we just need to load the interface
    2619 
    +--    and artifacts from disk.
    2620 
    +
    2612 2621 
     executeCompileNode :: Int
    2613 2622 
       -> Int
    2614 2623 
       -> Maybe HomeModInfo
    2615 2624 
       -> HomeUnitGraph
    2616 2625 
       -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling
    2617 
    -  -> ModSummary
    2626 
    +  -> ModuleNodeInfo
    2618 2627 
       -> RunMakeM HomeModInfo
    2619 
    -executeCompileNode k n !old_hmi hug mrehydrate_mods mod = do
    2628 
    +executeCompileNode k n !old_hmi hug mrehydrate_mods mni = do
    2620 2629 
       me@MakeEnv{..} <- ask
    2621 2630 
       -- Rehydrate any dependencies if this module had a boot file or is a signature file.
    2622 2631 
       lift $ MaybeT (withAbstractSem compile_sem $ withLoggerHsc k me $ \hsc_env -> do
    2623 
    -     hsc_env' <- liftIO $ maybeRehydrateBefore (setHUG hug hsc_env) mod fixed_mrehydrate_mods
    2632 
    +     hsc_env' <- liftIO $ maybeRehydrateBefore (setHUG hug hsc_env) mni fixed_mrehydrate_mods
    2633 
    +     case mni of
    2634 
    +       ModuleNodeCompile mod -> executeCompileNodeWithSource hsc_env' me mod
    2635 
    +       ModuleNodeFixed key loc -> executeCompileNodeFixed hsc_env' me key loc
    2636 
    +    )
    2637 
    +
    2638 
    +  where
    2639 
    +    fixed_mrehydrate_mods =
    2640 
    +      case moduleNodeInfoHscSource mni of
    2641 
    +        -- MP: It is probably a bit of a misimplementation in backpack that
    2642 
    +        -- compiling a signature requires an knot_var for that unit.
    2643 
    +        -- If you remove this then a lot of backpack tests fail.
    2644 
    +        Just HsigFile -> Just []
    2645 
    +        _        -> mrehydrate_mods
    2646 
    +
    2647 
    +    executeCompileNodeFixed :: HscEnv -> MakeEnv -> ModNodeKeyWithUid -> ModLocation -> IO (Maybe HomeModInfo)
    2648 
    +    executeCompileNodeFixed hsc_env MakeEnv{diag_wrapper, env_messager} mod_key loc =
    2649 
    +      wrapAction diag_wrapper hsc_env $ do
    2650 
    +        forM_ env_messager $ \hscMessage -> hscMessage hsc_env (k, n) UpToDate (ModuleNode [] (ModuleNodeFixed mod_key loc))
    2651 
    +        read_result <- readIface (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule mod_key) (ml_hi_file loc)
    2652 
    +        case read_result of
    2653 
    +          MB.Failed interface_err ->
    2654 
    +
    2655 
    +            let mn = mnkModuleName mod_key
    2656 
    +                err = Can'tFindInterface (BadIfaceFile interface_err) (LookingForModule (gwib_mod mn) (gwib_isBoot mn))
    2657 
    +            in throwErrors $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (GhcDriverMessage (DriverInterfaceError err))
    2658 
    +          MB.Succeeded iface -> do
    2659 
    +            details <- genModDetails hsc_env iface
    2660 
    +            mb_object <- findObjectLinkableMaybe (mi_module iface) loc
    2661 
    +            mb_bytecode <- loadIfaceByteCodeLazy hsc_env iface loc (md_types details)
    2662 
    +            let hm_linkable = HomeModLinkable mb_bytecode mb_object
    2663 
    +            return (HomeModInfo iface details hm_linkable)
    2664 
    +
    2665 
    +    executeCompileNodeWithSource :: HscEnv -> MakeEnv -> ModSummary -> IO (Maybe HomeModInfo)
    2666 
    +    executeCompileNodeWithSource hsc_env MakeEnv{diag_wrapper, env_messager} mod = do
    2624 2667 
          let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas
    2625 2668 
              lcl_dynflags = ms_hspp_opts mod
    2626 2669 
          let lcl_hsc_env =
    2627 2670 
                  -- Localise the hsc_env to use the cached flags
    2628 2671 
                  hscSetFlags lcl_dynflags $
    2629 
    -             hsc_env'
    2672 
    +             hsc_env
    2630 2673 
          -- Compile the module, locking with a semaphore to avoid too many modules
    2631 2674 
          -- being compiled at the same time leading to high memory usage.
    2632 2675 
          wrapAction diag_wrapper lcl_hsc_env $ do
    2633 2676 
           res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n
    2634 
    -      cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env') (hsc_tmpfs hsc_env') lcl_dynflags
    2635 
    -      return res)
    2636 
    -
    2637 
    -  where
    2638 
    -    fixed_mrehydrate_mods =
    2639 
    -      case ms_hsc_src mod of
    2640 
    -        -- MP: It is probably a bit of a misimplementation in backpack that
    2641 
    -        -- compiling a signature requires an knot_var for that unit.
    2642 
    -        -- If you remove this then a lot of backpack tests fail.
    2643 
    -        HsigFile -> Just []
    2644 
    -        _        -> mrehydrate_mods
    2677 
    +      cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags
    2678 
    +      return res
    2645 2679
    2646 2680 
     {- Rehydration, see Note [Rehydrating Modules] -}
    2647 2681
    ... ... @@ -2669,9 +2703,9 @@ rehydrate hsc_env hmis = do
    2669 2703
    2670 2704 
     -- If needed, then rehydrate the necessary modules with a suitable KnotVars for the
    2671 2705 
     -- module currently being compiled.
    2672 
    -maybeRehydrateBefore :: HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv
    2706 
    +maybeRehydrateBefore :: HscEnv -> ModuleNodeInfo -> Maybe [ModuleName] -> IO HscEnv
    2673 2707 
     maybeRehydrateBefore hsc_env _ Nothing = return hsc_env
    2674 
    -maybeRehydrateBefore hsc_env mod (Just mns) = do
    2708 
    +maybeRehydrateBefore hsc_env mni (Just mns) = do
    2675 2709 
       knot_var <- initialise_knot_var hsc_env
    2676 2710 
       let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var }
    2677 2711 
       hmis <- mapM (fmap (expectJust "mr") . lookupHpt (hsc_HPT hsc_env')) mns
    ... ... @@ -2681,7 +2715,7 @@ maybeRehydrateBefore hsc_env mod (Just mns) = do
    2681 2715
    2682 2716 
       where
    2683 2717 
        initialise_knot_var hsc_env = liftIO $
    2684 
    -    let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (ms_mod mod)
    2718 
    +    let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (moduleNodeInfoModule mni)
    2685 2719 
         in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv
    2686 2720
    2687 2721 
     rehydrateAfter :: HscEnv

  • compiler/GHC/Driver/MakeFile.hs
    ... ... @@ -14,55 +14,57 @@ module GHC.Driver.MakeFile
    14 14 
        )
    15 15 
     where
    16 16
    17 
    -import GHC.Prelude
    18 
    -
    17 
    +import Control.Monad (when)
    18 
    +import Data.Either (partitionEithers)
    19 
    +import Data.Foldable (traverse_)
    20 
    +import Data.IORef
    21 
    +import Data.List (partition)
    22 
    +import qualified Data.Set as Set
    19 23 
     import qualified GHC
    24 
    +import GHC.Data.Graph.Directed (SCC (..))
    20 25 
     import GHC.Data.Maybe
    21 
    -import GHC.Driver.Make
    22 
    -import GHC.Driver.Monad
    23 
    -import GHC.Driver.DynFlags
    24 
    -import GHC.Driver.Ppr
    25 
    -import GHC.Driver.MakeFile.JSON
    26 
    -import GHC.Utils.Misc
    27 
    -import GHC.Driver.Env
    28 
    -import GHC.Driver.Errors.Types
    29 
    -import GHC.Driver.Pipeline (runPipeline, TPhase (T_Unlit, T_FileArgs), use, mkPipeEnv)
    30 
    -import GHC.Driver.Phases (StopPhase (StopPreprocess), startPhase, Phase (Unlit))
    31 
    -import GHC.Driver.Pipeline.Monad (PipelineOutput (NoOutputFile))
    32 
    -import GHC.Driver.Session (pgm_F)
    33 
    -import qualified GHC.SysTools as SysTools
    34 
    -import GHC.Data.Graph.Directed ( SCC(..) )
    35 
    -import GHC.Data.OsPath (unsafeDecodeUtf, OsPath, OsString)
    36 26 
     import qualified GHC.Data.OsPath as OS
    37 
    -import GHC.Utils.Outputable
    38 
    -import GHC.Utils.Panic
    27 
    +import GHC.Data.OsPath (OsPath, OsString, unsafeDecodeUtf)
    28 
    +import GHC.Iface.Errors.Types
    29 
    +import GHC.Iface.Load (cannotFindModule)
    30 
    +import GHC.Prelude
    31 
    +import qualified GHC.SysTools as SysTools
    32 
    +import GHC.Types.PkgQual
    39 33 
     import GHC.Types.SourceError
    40 34 
     import GHC.Types.SrcLoc
    41 
    -import GHC.Types.PkgQual
    42 
    -import Data.List (partition)
    43 
    -import GHC.Utils.TmpFs
    44 
    -
    45 
    -import GHC.Iface.Load (cannotFindModule)
    46 
    -import GHC.Iface.Errors.Types
    47 
    -
    35 
    +import GHC.Unit.Finder
    48 36 
     import GHC.Unit.Module
    49 
    -import GHC.Unit.Module.ModSummary
    50 37 
     import GHC.Unit.Module.Graph
    51 
    -import GHC.Unit.Finder
    38 
    +import GHC.Unit.Module.ModSummary
    52 39 
     import GHC.Unit.State (lookupUnitId)
    53 
    -
    54 
    -import GHC.Utils.Exception
    55 40 
     import GHC.Utils.Error
    41 
    +import GHC.Utils.Exception
    56 42 
     import GHC.Utils.Logger
    57 
    -
    43 
    +import GHC.Utils.Misc
    44 
    +import GHC.Utils.Outputable
    45 
    +import GHC.Utils.Panic
    46 
    +import GHC.Utils.TmpFs
    58 47 
     import System.Directory
    59 48 
     import System.FilePath
    60 49 
     import System.IO
    61 
    -import System.IO.Error  ( isEOFError )
    62 
    -import Control.Monad    ( when )
    63 
    -import Data.Foldable (traverse_)
    64 
    -import Data.IORef
    65 
    -import qualified Data.Set as Set
    50 
    +import System.IO.Error (isEOFError)
    51 
    +
    52 
    +import GHC.Driver.DynFlags
    53 
    +import GHC.Driver.Env
    54 
    +import GHC.Driver.Errors.Types
    55 
    +import GHC.Driver.Make
    56 
    +import GHC.Driver.MakeFile.JSON
    57 
    +import GHC.Driver.Monad
    58 
    +import GHC.Driver.Phases (Phase (Unlit), StopPhase (StopPreprocess), startPhase)
    59 
    +import GHC.Driver.Pipeline (
    60 
    +  TPhase (T_FileArgs, T_Unlit),
    61 
    +  mkPipeEnv,
    62 
    +  runPipeline,
    63 
    +  use,
    64 
    +  )
    65 
    +import GHC.Driver.Pipeline.Monad (PipelineOutput (NoOutputFile))
    66 
    +import GHC.Driver.Ppr
    67 
    +import GHC.Driver.Session (pgm_F)
    66 68
    67 69 
     -----------------------------------------------------------------
    68 70 
     --
    ... ... @@ -234,8 +236,10 @@ processDeps dflags _ _ _ _ _ (AcyclicSCC (InstantiationNode _uid node))
    234 236 
             vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:"
    235 237 
                  , nest 2 $ ppr node ]
    236 238 
     processDeps _dflags_ _ _ _ _ _ (AcyclicSCC (LinkNode {})) = return ()
    237 
    -
    238 
    -processDeps dflags hsc_env excl_mods root hdl m_dep_json (AcyclicSCC (ModuleNode _ node)) = do
    239 
    +processDeps _ _ _ _ _ _ (AcyclicSCC (ModuleNode _ (ModuleNodeFixed {})))
    240 
    +  -- No dependencies needed for fixed modules (already compiled)
    241 
    +  = return ()
    242 
    +processDeps dflags hsc_env excl_mods root hdl m_dep_json (AcyclicSCC (ModuleNode _ (ModuleNodeCompile node))) = do
    239 243 
       pp <- preprocessor
    240 244 
       deps <- fmap concat $ sequence $
    241 245 
         [cpp_deps | depIncludeCppDeps dflags] ++ [
    ... ... @@ -472,43 +476,62 @@ pprCycle :: [ModuleGraphNode] -> SDoc
    472 476 
     -- Print a cycle, but show only the imports within the cycle
    473 477 
     pprCycle summaries = pp_group (CyclicSCC summaries)
    474 478 
       where
    475 
    -    cycle_mods :: [ModuleName]  -- The modules in this cycle
    476 
    -    cycle_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- summaries]
    479 
    +    cycle_keys :: [NodeKey]  -- The modules in this cycle
    480 
    +    cycle_keys = map mkNodeKey summaries
    477 481
    478 482 
         pp_group :: SCC ModuleGraphNode -> SDoc
    479 
    -    pp_group (AcyclicSCC (ModuleNode _ ms)) = pp_ms ms
    483 
    +    pp_group (AcyclicSCC (ModuleNode deps m)) = pp_mod deps m
    480 484 
         pp_group (AcyclicSCC _) = empty
    481 485 
         pp_group (CyclicSCC mss)
    482 486 
             = assert (not (null boot_only)) $
    483 487 
                     -- The boot-only list must be non-empty, else there would
    484 488 
                     -- be an infinite chain of non-boot imports, and we've
    485 489 
                     -- already checked for that in processModDeps
    486 
    -          pp_ms loop_breaker $$ vcat (map pp_group groups)
    490 
    +          pp_mod loop_deps loop_breaker $$ vcat (map pp_group groups)
    487 491 
             where
    488 
    -          (boot_only, others) = partition is_boot_only mss
    489 
    -          is_boot_only (ModuleNode _ ms) = not (any in_group (map snd (ms_imps ms)))
    490 
    -          is_boot_only  _ = False
    491 
    -          in_group (L _ m) = m `elem` group_mods
    492 
    -          group_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- mss]
    493 
    -
    494 
    -          loop_breaker = head ([ms | ModuleNode _ ms  <- boot_only])
    495 
    -          all_others   = tail boot_only ++ others
    492 
    +          (boot_only, others) = partitionEithers (map is_boot_only mss)
    493 
    +          is_boot_key (NodeKey_Module (ModNodeKeyWithUid (GWIB _ IsBoot) _)) = True
    494 
    +          is_boot_key _ = False
    495 
    +          is_boot_only n@(ModuleNode deps ms) =
    496 
    +            let non_boot_deps = filter (not . is_boot_key) deps
    497 
    +            in if not (any in_group non_boot_deps)
    498 
    +                then Left (deps, ms)
    499 
    +                else Right n
    500 
    +          is_boot_only n = Right n
    501 
    +          in_group m = m `elem` group_mods
    502 
    +          group_mods = map mkNodeKey mss
    503 
    +
    504 
    +          (loop_deps, loop_breaker) = head boot_only
    505 
    +          all_others   = tail (map (uncurry ModuleNode) boot_only) ++ others
    496 506 
               groups =
    497 507 
                 GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing
    498 508
    499 
    -    pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))
    500 
    -                       <+> (pp_imps empty (map snd (ms_imps summary)) $$
    501 
    -                            pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary)))
    502 
    -        where
    503 
    -          mod_str = moduleNameString (moduleName (ms_mod summary))
    504 
    -
    505 
    -    pp_imps :: SDoc -> [Located ModuleName] -> SDoc
    506 
    -    pp_imps _    [] = empty
    507 
    -    pp_imps what lms
    508 
    -        = case [m | L _ m <- lms, m `elem` cycle_mods] of
    509 
    -            [] -> empty
    510 
    -            ms -> what <+> text "imports" <+>
    511 
    -                                pprWithCommas ppr ms
    509 
    +    pp_mod :: [NodeKey] -> ModuleNodeInfo -> SDoc
    510 
    +    pp_mod deps mn =
    511 
    +      text mod_str <> text (take (20 - length mod_str) (repeat ' ')) <> ppr_deps deps
    512 
    +      where
    513 
    +        mod_str = moduleNameString (moduleNodeInfoModuleName mn)
    514 
    +
    515 
    +    ppr_deps :: [NodeKey] -> SDoc
    516 
    +    ppr_deps [] = empty
    517 
    +    ppr_deps deps =
    518 
    +      let is_mod_dep (NodeKey_Module {}) = True
    519 
    +          is_mod_dep _ = False
    520 
    +
    521 
    +          is_boot_dep (NodeKey_Module (ModNodeKeyWithUid (GWIB _ IsBoot) _)) = True
    522 
    +          is_boot_dep _ = False
    523 
    +
    524 
    +          cycle_deps = filter (`elem` cycle_keys) deps
    525 
    +          (mod_deps, other_deps) = partition is_mod_dep cycle_deps
    526 
    +          (boot_deps, normal_deps) = partition is_boot_dep mod_deps
    527 
    +      in vcat [
    528 
    +           if null normal_deps then empty
    529 
    +           else text "imports" <+> pprWithCommas ppr normal_deps,
    530 
    +           if null boot_deps then empty
    531 
    +           else text "{-# SOURCE #-} imports" <+> pprWithCommas ppr boot_deps,
    532 
    +           if null other_deps then empty
    533 
    +           else text "depends on" <+> pprWithCommas ppr other_deps
    534 
    +         ]
    512 535
    513 536 
     -----------------------------------------------------------------
    514 537 
     --

  • compiler/GHC/Runtime/Eval.hs
    ... ... @@ -1262,19 +1262,20 @@ dynCompileExpr expr = do
    1262 1262 
     -----------------------------------------------------------------------------
    1263 1263 
     -- show a module and it's source/object filenames
    1264 1264
    1265 
    -showModule :: GhcMonad m => ModSummary -> m String
    1266 
    -showModule mod_summary =
    1265 
    +showModule :: GhcMonad m => ModuleNodeInfo -> m String
    1266 
    +showModule mni = do
    1267 
    +    let mod = moduleNodeInfoModule mni
    1267 1268 
         withSession $ \hsc_env -> do
    1268 1269 
             let dflags = hsc_dflags hsc_env
    1269 1270 
             interpreted <- liftIO $
    1270 
    -          HUG.lookupHug (hsc_HUG hsc_env) (ms_unitid mod_summary) (ms_mod_name mod_summary) >>= pure . \case
    1271 
    +          HUG.lookupHug (hsc_HUG hsc_env) (moduleUnitId mod) (moduleName mod) >>= pure . \case
    1271 1272 
                 Nothing       -> panic "missing linkable"
    1272 1273 
                 Just mod_info -> isJust (homeModInfoByteCode mod_info)  && isNothing (homeModInfoObject mod_info)
    1273 
    -        return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mod_summary))
    1274 
    +        return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mni))
    1274 1275
    1275 
    -moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool
    1276 
    -moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env -> liftIO $
    1277 
    -  HUG.lookupHug (hsc_HUG hsc_env) (ms_unitid mod_summary) (ms_mod_name mod_summary) >>= pure . \case
    1276 
    +moduleIsBootOrNotObjectLinkable :: GhcMonad m => Module -> m Bool
    1277 
    +moduleIsBootOrNotObjectLinkable mod = withSession $ \hsc_env -> liftIO $
    1278 
    +  HUG.lookupHug (hsc_HUG hsc_env) (moduleUnitId mod) (moduleName mod) >>= pure . \case
    1278 1279 
         Nothing       -> panic "missing linkable"
    1279 1280 
         Just mod_info -> isNothing $ homeModInfoByteCode mod_info
    1280 1281

  • compiler/GHC/Unit/Module/Graph.hs
    ... ... @@ -8,6 +8,12 @@ module GHC.Unit.Module.Graph
    8 8 
        , nodeDependencies
    9 9 
        , emptyMG
    10 10 
        , mkModuleGraph
    11 
    +   , mkModuleGraphChecked
    12 
    +
    13 
    +   -- * Invariant checking
    14 
    +   , checkModuleGraph
    15 
    +   , ModuleGraphInvariantError(..)
    16 
    +
    11 17 
        , extendMG
    12 18 
        , extendMGInst
    13 19 
        , extendMG'
    ... ... @@ -22,6 +28,7 @@ module GHC.Unit.Module.Graph
    22 28 
        , mgHomeModuleMap
    23 29 
        , showModMsg
    24 30 
        , moduleGraphNodeModule
    31 
    +   , mgNodeIsModule
    25 32 
        , moduleGraphNodeModSum
    26 33 
        , moduleGraphModulesBelow
    27 34 
        , mgReachable
    ... ... @@ -38,46 +45,51 @@ module GHC.Unit.Module.Graph
    38 45 
        , ModNodeKey
    39 46 
        , mkNodeKey
    40 47 
        , msKey
    41 
    -
    48 
    +   , mnKey
    42 49
    43 50 
        , moduleGraphNodeUnitId
    44 51
    45 52 
        , ModNodeKeyWithUid(..)
    53 
    +   , mnkToModule
    54 
    +   , mnkIsBoot
    55 
    +
    56 
    +   , ModuleNodeInfo(..)
    57 
    +   , moduleNodeInfoModule
    58 
    +   , moduleNodeInfoModuleName
    59 
    +   , moduleNodeInfoModNodeKeyWithUid
    60 
    +   , moduleNodeInfoHscSource
    61 
    +   , moduleNodeInfoLocation
    62 
    +   , isBootModuleNodeInfo
    46 63 
        )
    47 64 
     where
    48 65
    49 
    -import GHC.Prelude
    50 
    -import GHC.Platform
    51 
    -
    52 
    -import qualified GHC.LanguageExtensions as LangExt
    53 
    -
    54 
    -import GHC.Data.Maybe
    66 
    +import Data.Bifunctor
    67 
    +import Data.Either
    68 
    +import Data.Function
    69 
    +import Data.List (sort)
    70 
    +import qualified Data.Map as Map
    71 
    +import qualified Data.Set as Set
    72 
    +import Data.Set (Set)
    55 73 
     import GHC.Data.Graph.Directed
    56 74 
     import GHC.Data.Graph.Directed.Reachability
    57 
    -
    75 
    +import GHC.Data.List.SetOps
    76 
    +import GHC.Data.Maybe
    58 77 
     import GHC.Driver.Backend
    59 78 
     import GHC.Driver.DynFlags
    60 
    -
    61 
    -import GHC.Types.SourceFile ( hscSourceString, isHsigFile )
    62 
    -
    63 
    -import GHC.Unit.Module.ModSummary
    64 
    -import GHC.Unit.Types
    79 
    +import qualified GHC.LanguageExtensions as LangExt
    80 
    +import GHC.Linker.Static.Utils
    81 
    +import GHC.Platform
    82 
    +import GHC.Prelude
    83 
    +import GHC.Stack
    84 
    +import GHC.Types.SourceFile (HscSource (..), hscSourceString, isHsigFile)
    85 
    +import GHC.Types.Unique.DSet
    86 
    +import GHC.Utils.Misc (partitionWith)
    65 87 
     import GHC.Utils.Outputable
    66 
    -import GHC.Utils.Misc ( partitionWith )
    67 
    -
    68 88 
     import System.FilePath
    69 
    -import qualified Data.Map as Map
    70 
    -import GHC.Types.Unique.DSet
    71 
    -import qualified Data.Set as Set
    72 
    -import Data.Set (Set)
    73 
    -import GHC.Unit.Module
    74 
    -import GHC.Linker.Static.Utils
    75 89
    76 
    -import Data.Bifunctor
    77 
    -import Data.Function
    78 
    -import Data.List (sort)
    79 
    -import GHC.Data.List.SetOps
    80 
    -import GHC.Stack
    90 
    +import GHC.Unit.Module
    91 
    +import GHC.Unit.Module.ModSummary
    92 
    +import GHC.Unit.Types
    81 93
    82 94 
     -- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'.
    83 95 
     -- Edges between nodes mark dependencies arising from module imports
    ... ... @@ -86,30 +98,166 @@ data ModuleGraphNode
    86 98 
       -- | Instantiation nodes track the instantiation of other units
    87 99 
       -- (backpack dependencies) with the holes (signatures) of the current package.
    88 100 
       = InstantiationNode UnitId InstantiatedUnit
    89 
    -  -- | There is a module summary node for each module, signature, and boot module being built.
    90 
    -  | ModuleNode [NodeKey] ModSummary
    101 
    +  -- | There is a module node for each module being built.
    102 
    +  -- A node is either fixed or can be compiled.
    103 
    +  -- - Fixed modules are not compiled, the artifacts are just loaded from disk.
    104 
    +  --   It is up to you to make sure the artifacts are up to date and available.
    105 
    +  -- - Compile modules are compiled from source if needed.
    106 
    +  | ModuleNode [NodeKey] ModuleNodeInfo
    91 107 
       -- | Link nodes are whether are are creating a linked product (ie executable/shared object etc) for a unit.
    92 108 
       | LinkNode [NodeKey] UnitId
    93 109
    110 
    +
    111 
    +data ModuleGraphInvariantError =
    112 
    +        FixedNodeDependsOnCompileNode ModNodeKeyWithUid [NodeKey]
    113 
    +      | DuplicateModuleNodeKey NodeKey
    114 
    +      | DependencyNotInGraph NodeKey [NodeKey]
    115 
    +      deriving (Eq, Ord)
    116 
    +
    117 
    +instance Outputable ModuleGraphInvariantError where
    118 
    +  ppr = \case
    119 
    +    FixedNodeDependsOnCompileNode key bad_deps ->
    120 
    +      text "Fixed node" <+> ppr key <+> text "depends on compile nodes" <+> ppr bad_deps
    121 
    +    DuplicateModuleNodeKey k ->
    122 
    +      text "Duplicate module node key" <+> ppr k
    123 
    +    DependencyNotInGraph from to ->
    124 
    +      text "Dependency not in graph" <+> ppr from <+> text "->" <+> ppr to
    125 
    +
    126 
    +-- Used for invariant checking. Is a NodeKey fixed or compilable?
    127 
    +data ModuleNodeType = MN_Fixed | MN_Compile
    128 
    +
    129 
    +instance Outputable ModuleNodeType where
    130 
    +  ppr = \case
    131 
    +    MN_Fixed -> text "Fixed"
    132 
    +    MN_Compile -> text "Compile"
    133 
    +
    134 
    +moduleNodeType :: ModuleGraphNode -> ModuleNodeType
    135 
    +moduleNodeType (ModuleNode _ (ModuleNodeCompile _)) = MN_Compile
    136 
    +moduleNodeType (ModuleNode _ (ModuleNodeFixed _ _)) = MN_Fixed
    137 
    +moduleNodeType _ = MN_Compile
    138 
    +
    139 
    +checkModuleGraph :: ModuleGraph -> [ModuleGraphInvariantError]
    140 
    +checkModuleGraph ModuleGraph{..} =
    141 
    +  mapMaybe (checkFixedModuleInvariant node_types) mg_mss
    142 
    +  ++ mapMaybe (checkAllDependenciesInGraph node_types) mg_mss
    143 
    +  ++ duplicate_errs
    144 
    +  where
    145 
    +    duplicate_errs = rights (Map.elems node_types)
    146 
    +
    147 
    +    node_types :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
    148 
    +    node_types = Map.fromListWithKey go [ (mkNodeKey n, Left (moduleNodeType n)) | n <- mg_mss ]
    149 
    +      where
    150 
    +        go :: NodeKey -> Either ModuleNodeType ModuleGraphInvariantError
    151 
    +                      -> Either ModuleNodeType ModuleGraphInvariantError
    152 
    +                      -> Either ModuleNodeType ModuleGraphInvariantError
    153 
    +        go k _ _ = Right (DuplicateModuleNodeKey k)
    154 
    +
    155 
    +checkAllDependenciesInGraph :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
    156 
    +                            -> ModuleGraphNode
    157 
    +                            -> Maybe ModuleGraphInvariantError
    158 
    +checkAllDependenciesInGraph node_types node =
    159 
    +  let nodeKey = mkNodeKey node
    160 
    +      deps = nodeDependencies False node
    161 
    +      missingDeps = filter (\dep -> not (Map.member dep node_types)) deps
    162 
    +  in if null missingDeps
    163 
    +     then Nothing
    164 
    +     else Just (DependencyNotInGraph nodeKey missingDeps)
    165 
    +
    166 
    +checkFixedModuleInvariant :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
    167 
    +                -> ModuleGraphNode
    168 
    +                -> Maybe ModuleGraphInvariantError
    169 
    +checkFixedModuleInvariant node_types node = case node of
    170 
    +  ModuleNode deps (ModuleNodeFixed key _) ->
    171 
    +    let check_node dep = case Map.lookup dep node_types of
    172 
    +                           Just (Left MN_Compile) -> Just dep
    173 
    +                           _ -> Nothing
    174 
    +        bad_deps = mapMaybe check_node deps
    175 
    +    in if null bad_deps
    176 
    +       then Nothing
    177 
    +       else Just (FixedNodeDependsOnCompileNode key bad_deps)
    178 
    +  _ -> Nothing
    179 
    +
    180 
    +
    181 
    +{- Note [Module Types in the ModuleGraph]
    182 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    183 
    +
    184 
    +Modules can be one of two different types in the module graph.
    185 
    +
    186 
    +1. ModuleNodeCompile, modules with source files we can compile.
    187 
    +2. ModuleNodeFixed, modules which we presume are already compiled and available.
    188 
    +
    189 
    +The ModuleGraph can contain a combination of these two types of nodes but must
    190 
    +obey the invariant that Fixed nodes only depend on other Fixed nodes. This invariant
    191 
    +can be checked by the `checkModuleGraph` function, but it's
    192 
    +the responsibility of the code constructing the ModuleGraph to ensure it is upheld.
    193 
    +
    194 
    +At the moment, when using --make mode, GHC itself will only use `ModuleNodeCompile` nodes.
    195 
    +
    196 
    +In oneshot mode, we don't have access to the source files of dependencies but sometimes need to know
    197 
    +information about the module graph still (for example, getLinkDeps).
    198 
    +
    199 
    +In theory, the whole compiler will work if an API program uses ModuleNodeFixed nodes, and
    200 
    +there is a simple test in FixedNodes, which can be extended in future to cover
    201 
    +any missing cases.
    202 
    +
    203 
    +-}
    204 
    +data ModuleNodeInfo = ModuleNodeFixed ModNodeKeyWithUid ModLocation
    205 
    +                    | ModuleNodeCompile ModSummary
    206 
    +
    207 
    +-- | Extract the Module from a ModuleNodeInfo
    208 
    +moduleNodeInfoModule :: ModuleNodeInfo -> Module
    209 
    +moduleNodeInfoModule (ModuleNodeFixed key _) = mnkToModule key
    210 
    +moduleNodeInfoModule (ModuleNodeCompile ms) = ms_mod ms
    211 
    +
    212 
    +-- | Extract the ModNodeKeyWithUid from a ModuleNodeInfo
    213 
    +moduleNodeInfoModNodeKeyWithUid :: ModuleNodeInfo -> ModNodeKeyWithUid
    214 
    +moduleNodeInfoModNodeKeyWithUid (ModuleNodeFixed key _) = key
    215 
    +moduleNodeInfoModNodeKeyWithUid (ModuleNodeCompile ms) = msKey ms
    216 
    +
    217 
    +-- | Extract the HscSource from a ModuleNodeInfo, if we can determine it.
    218 
    +moduleNodeInfoHscSource :: ModuleNodeInfo -> Maybe HscSource
    219 
    +moduleNodeInfoHscSource (ModuleNodeFixed _ _) = Nothing
    220 
    +moduleNodeInfoHscSource (ModuleNodeCompile ms) = Just (ms_hsc_src ms)
    221 
    +
    222 
    +-- | Extract the ModLocation from a ModuleNodeInfo
    223 
    +moduleNodeInfoLocation :: ModuleNodeInfo -> ModLocation
    224 
    +moduleNodeInfoLocation (ModuleNodeFixed _ loc) = loc
    225 
    +moduleNodeInfoLocation (ModuleNodeCompile ms) = ms_location ms
    226 
    +
    227 
    +-- | Extract the IsBootInterface from a ModuleNodeInfo
    228 
    +isBootModuleNodeInfo :: ModuleNodeInfo -> IsBootInterface
    229 
    +isBootModuleNodeInfo (ModuleNodeFixed mnwib _) = mnkIsBoot mnwib
    230 
    +isBootModuleNodeInfo (ModuleNodeCompile ms) = isBootSummary ms
    231 
    +
    232 
    +-- | Extract the ModuleName from a ModuleNodeInfo
    233 
    +moduleNodeInfoModuleName :: ModuleNodeInfo -> ModuleName
    234 
    +moduleNodeInfoModuleName m = moduleName (moduleNodeInfoModule m)
    235 
    +
    94 236 
     moduleGraphNodeModule :: ModuleGraphNode -> Maybe ModuleName
    95 
    -moduleGraphNodeModule mgn = ms_mod_name <$> (moduleGraphNodeModSum mgn)
    237 
    +moduleGraphNodeModule mgn = moduleNodeInfoModuleName <$> (mgNodeIsModule mgn)
    96 238
    97 239 
     moduleGraphNodeModSum :: ModuleGraphNode -> Maybe ModSummary
    98 240 
     moduleGraphNodeModSum (InstantiationNode {}) = Nothing
    99 241 
     moduleGraphNodeModSum (LinkNode {})          = Nothing
    100 
    -moduleGraphNodeModSum (ModuleNode _ ms)      = Just ms
    242 
    +moduleGraphNodeModSum (ModuleNode _ (ModuleNodeCompile ms)) = Just ms
    243 
    +moduleGraphNodeModSum (ModuleNode _ (ModuleNodeFixed {}))    = Nothing
    244 
    +
    245 
    +mgNodeIsModule :: ModuleGraphNode -> Maybe ModuleNodeInfo
    246 
    +mgNodeIsModule (InstantiationNode {}) = Nothing
    247 
    +mgNodeIsModule (LinkNode {})          = Nothing
    248 
    +mgNodeIsModule (ModuleNode _ ms)      = Just ms
    101 249
    102 250 
     moduleGraphNodeUnitId :: ModuleGraphNode -> UnitId
    103 251 
     moduleGraphNodeUnitId mgn =
    104 252 
       case mgn of
    105 253 
         InstantiationNode uid _iud -> uid
    106 
    -    ModuleNode _ ms           -> toUnitId (moduleUnit (ms_mod ms))
    254 
    +    ModuleNode _ ms           -> toUnitId (moduleUnit (moduleNodeInfoModule ms))
    107 255 
         LinkNode _ uid             -> uid
    108 256
    109 257 
     instance Outputable ModuleGraphNode where
    110 258 
       ppr = \case
    111 259 
         InstantiationNode _ iuid -> ppr iuid
    112 
    -    ModuleNode nks ms -> ppr (msKey ms) <+> ppr nks
    260 
    +    ModuleNode nks ms -> ppr (mnKey ms) <+> ppr nks
    113 261 
         LinkNode uid _     -> text "LN:" <+> ppr uid
    114 262
    115 263 
     instance Eq ModuleGraphNode where
    ... ... @@ -146,6 +294,12 @@ data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: !ModuleNameWithIsB
    146 294 
     instance Outputable ModNodeKeyWithUid where
    147 295 
       ppr (ModNodeKeyWithUid mnwib uid) = ppr uid <> colon <> ppr mnwib
    148 296
    297 
    +mnkIsBoot :: ModNodeKeyWithUid -> IsBootInterface
    298 
    +mnkIsBoot (ModNodeKeyWithUid mnwib _) = gwib_isBoot mnwib
    299 
    +
    300 
    +mnkToModule :: ModNodeKeyWithUid -> Module
    301 
    +mnkToModule (ModNodeKeyWithUid mnwib uid) = Module (RealUnit (Definite uid)) (gwib_mod mnwib)
    302 
    +
    149 303 
     -- | A '@ModuleGraph@' contains all the nodes from the home package (only). See
    150 304 
     -- '@ModuleGraphNode@' for information about the nodes.
    151 305 
     --
    ... ... @@ -181,7 +335,8 @@ mapMG f mg@ModuleGraph{..} = mg
    181 335 
           flip fmap mg_mss $ \case
    182 336 
             InstantiationNode uid iuid -> InstantiationNode uid iuid
    183 337 
             LinkNode uid nks -> LinkNode uid nks
    184 
    -        ModuleNode deps ms  -> ModuleNode deps (f ms)
    338 
    +        ModuleNode deps (ModuleNodeFixed key loc) -> ModuleNode deps (ModuleNodeFixed key loc)
    339 
    +        ModuleNode deps (ModuleNodeCompile ms) -> ModuleNode deps (ModuleNodeCompile (f ms))
    185 340
    186 341 
     unionMG :: ModuleGraph -> ModuleGraph -> ModuleGraph
    187 342 
     unionMG a b =
    ... ... @@ -201,30 +356,30 @@ mkHomeModuleMap nodes =
    201 356 
       where
    202 357 
         provider_map =
    203 358 
           Map.fromListWith Set.union
    204 
    -        [ (ms_mod_name ms, Set.singleton (ms_unitid ms))
    359 
    +        [ (moduleNodeInfoModuleName ms, Set.singleton (toUnitId (moduleUnit (moduleNodeInfoModule ms))))
    205 360 
             | ModuleNode _ ms <- nodes
    206 361 
             ]
    207 362 
         complete_units =
    208 363 
           Set.fromList
    209 
    -        [ ms_unitid ms
    364 
    +        [ toUnitId (moduleUnit (moduleNodeInfoModule ms))
    210 365 
             | ModuleNode _ ms <- nodes
    211 366 
             ]
    212 367
    213 368 
     mgModSummaries :: ModuleGraph -> [ModSummary]
    214 
    -mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ]
    369 
    +mgModSummaries mg = [ m | ModuleNode _ (ModuleNodeCompile m) <- mgModSummaries' mg ]
    215 370
    216 371 
     mgModSummaries' :: ModuleGraph -> [ModuleGraphNode]
    217 372 
     mgModSummaries' = mg_mss
    218 373
    219 
    --- | Look up a ModSummary in the ModuleGraph
    220 
    --- Looks up the non-boot ModSummary
    374 
    +-- | Look up a ModuleNodeInfo in the ModuleGraph
    375 
    +-- Looks up the non-boot module
    221 376 
     -- Linear in the size of the module graph
    222 
    -mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary
    377 
    +mgLookupModule :: ModuleGraph -> Module -> Maybe ModuleNodeInfo
    223 378 
     mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss
    224 379 
       where
    225 380 
         go (ModuleNode _ ms)
    226 
    -      | NotBoot <- isBootSummary ms
    227 
    -      , ms_mod ms == m
    381 
    +      | NotBoot <- isBootModuleNodeInfo ms
    382 
    +      , moduleNodeInfoModule ms == m
    228 383 
           = Just ms
    229 384 
         go _ = Nothing
    230 385
    ... ... @@ -261,7 +416,7 @@ extendMG ModuleGraph{..} deps ms = ModuleGraph
    261 416 
       , mg_has_holes = False
    262 417 
       }
    263 418 
       where
    264 
    -    new_mss = ModuleNode deps ms : mg_mss
    419 
    +    new_mss = ModuleNode deps (ModuleNodeCompile ms) : mg_mss
    265 420
    266 421 
     extendMGInst :: ModuleGraph -> UnitId -> InstantiatedUnit -> ModuleGraph
    267 422 
     extendMGInst mg uid depUnitId = mg
    ... ... @@ -274,18 +429,32 @@ extendMGLink mg uid nks = mg { mg_mss = LinkNode nks uid : mg_mss mg }
    274 429 
     extendMG' :: ModuleGraph -> ModuleGraphNode -> ModuleGraph
    275 430 
     extendMG' mg = \case
    276 431 
       InstantiationNode uid depUnitId -> extendMGInst mg uid depUnitId
    277 
    -  ModuleNode deps ms -> extendMG mg deps ms
    432 
    +  ModuleNode deps (ModuleNodeCompile ms) -> extendMG mg deps ms
    433 
    +  ModuleNode deps mni -> mg
    434 
    +    { mg_mss = ModuleNode deps mni : mg_mss mg
    435 
    +    , mg_graph = mkTransDeps (ModuleNode deps mni : mg_mss mg)
    436 
    +    , mg_home_map = mkHomeModuleMap (ModuleNode deps mni : mg_mss mg)
    437 
    +    , mg_has_holes = mg_has_holes mg || maybe False isHsigFile (moduleNodeInfoHscSource mni)
    438 
    +    }
    278 439 
       LinkNode deps uid   -> extendMGLink mg uid deps
    279 440
    280 441 
     mkModuleGraph :: [ModuleGraphNode] -> ModuleGraph
    281 442 
     mkModuleGraph = foldr (flip extendMG') emptyMG
    282 443
    444 
    +-- | A version of mkModuleGraph that checks the module graph for invariants.
    445 
    +mkModuleGraphChecked :: [ModuleGraphNode] -> Either [ModuleGraphInvariantError] ModuleGraph
    446 
    +mkModuleGraphChecked nodes =
    447 
    +  let mg = mkModuleGraph nodes
    448 
    +  in case checkModuleGraph mg of
    449 
    +       [] -> Right mg
    450 
    +       errors -> Left errors
    451 
    +
    283 452 
     -- | This function filters out all the instantiation nodes from each SCC of a
    284 453 
     -- topological sort. Use this with care, as the resulting "strongly connected components"
    285 454 
     -- may not really be strongly connected in a direct way, as instantiations have been
    286 455 
     -- removed. It would probably be best to eliminate uses of this function where possible.
    287 456 
     filterToposortToModules
    288 
    -  :: [SCC ModuleGraphNode] -> [SCC ModSummary]
    457 
    +  :: [SCC ModuleGraphNode] -> [SCC ModuleNodeInfo]
    289 458 
     filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case
    290 459 
       InstantiationNode _ _ -> Nothing
    291 460 
       LinkNode{} -> Nothing
    ... ... @@ -314,28 +483,43 @@ showModMsg dflags _ (LinkNode {}) =
    314 483 
           in text exe_file
    315 484 
     showModMsg _ _ (InstantiationNode _uid indef_unit) =
    316 485 
       ppr $ instUnitInstanceOf indef_unit
    317 
    -showModMsg dflags recomp (ModuleNode _ mod_summary) =
    486 
    +showModMsg dflags recomp (ModuleNode _ mni) =
    318 487 
       if gopt Opt_HideSourcePaths dflags
    319 488 
           then text mod_str
    320 489 
           else hsep $
    321 490 
              [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ')
    322 491 
              , char '('
    323 
    -         , text (op $ msHsFilePath mod_summary) <> char ','
    324 
    -         , message, char ')' ]
    325 
    -
    492 
    +         , text (moduleNodeInfoSource mni) <> char ','
    493 
    +         , moduleNodeInfoExtraMessage dflags recomp mni, char ')' ]
    326 494 
       where
    327 
    -    op       = normalise
    328 
    -    mod_str  = moduleNameString (moduleName (ms_mod mod_summary)) ++
    329 
    -               hscSourceString (ms_hsc_src mod_summary)
    330 
    -    dyn_file = op $ msDynObjFilePath mod_summary
    331 
    -    obj_file = op $ msObjFilePath mod_summary
    332 
    -    files    = [ obj_file ]
    333 
    -               ++ [ dyn_file | gopt Opt_BuildDynamicToo dflags ]
    334 
    -               ++ [ "interpreted" | gopt Opt_ByteCodeAndObjectCode dflags ]
    335 
    -    message = case backendSpecialModuleSource (backend dflags) recomp of
    336 
    -                Just special -> text special
    337 
    -                Nothing -> foldr1 (\ofile rest -> ofile <> comma <+> rest) (map text files)
    338 
    -
    495 
    +    mod_str  = moduleNameString (moduleName (moduleNodeInfoModule mni)) ++
    496 
    +               moduleNodeInfoBootString mni
    497 
    +
    498 
    +-- | Extra information about a 'ModuleNodeInfo' to display in the progress message.
    499 
    +moduleNodeInfoExtraMessage :: DynFlags -> Bool -> ModuleNodeInfo -> SDoc
    500 
    +moduleNodeInfoExtraMessage dflags recomp (ModuleNodeCompile mod_summary) =
    501 
    +    let dyn_file = normalise $ msDynObjFilePath mod_summary
    502 
    +        obj_file = normalise $ msObjFilePath mod_summary
    503 
    +        files    = [ obj_file ]
    504 
    +                   ++ [ dyn_file | gopt Opt_BuildDynamicToo dflags ]
    505 
    +                   ++ [ "interpreted" | gopt Opt_ByteCodeAndObjectCode dflags ]
    506 
    +    in case backendSpecialModuleSource (backend dflags) recomp of
    507 
    +              Just special -> text special
    508 
    +              Nothing -> foldr1 (\ofile rest -> ofile <> comma <+> rest) (map text files)
    509 
    +moduleNodeInfoExtraMessage _ _ (ModuleNodeFixed {}) = text "fixed"
    510 
    +
    511 
    +-- | The source location of the module node to show to the user.
    512 
    +moduleNodeInfoSource :: ModuleNodeInfo -> FilePath
    513 
    +moduleNodeInfoSource (ModuleNodeCompile ms) = normalise $ msHsFilePath ms
    514 
    +moduleNodeInfoSource (ModuleNodeFixed _ loc) = normalise $ ml_hi_file loc
    515 
    +
    516 
    +-- | The extra info about a module [boot] or [sig] to display.
    517 
    +moduleNodeInfoBootString :: ModuleNodeInfo -> String
    518 
    +moduleNodeInfoBootString (ModuleNodeCompile ms) = hscSourceString (ms_hsc_src ms)
    519 
    +moduleNodeInfoBootString mn@(ModuleNodeFixed {}) =
    520 
    +  hscSourceString (case isBootModuleNodeInfo mn of
    521 
    +                      IsBoot -> HsBootFile
    522 
    +                      NotBoot -> HsSrcFile)
    339 523
    340 524
    341 525 
     type SummaryNode = Node Int ModuleGraphNode
    ... ... @@ -384,14 +568,14 @@ moduleGraphNodes drop_hs_boot_nodes summaries =
    384 568 
           where
    385 569 
             go (s, key) =
    386 570 
               case s of
    387 
    -                ModuleNode __deps ms | isBootSummary ms == IsBoot, drop_hs_boot_nodes
    571 
    +                ModuleNode __deps ms | isBootModuleNodeInfo ms == IsBoot, drop_hs_boot_nodes
    388 572 
                       -- Using nodeDependencies here converts dependencies on other
    389 573 
                       -- boot files to dependencies on dependencies on non-boot files.
    390 
    -                  -> Left (ms_mod ms, nodeDependencies drop_hs_boot_nodes s)
    574 
    +                  -> Left (moduleNodeInfoModule ms, nodeDependencies drop_hs_boot_nodes s)
    391 575 
                     _ -> normal_case
    392 576 
               where
    393 577 
                normal_case =
    394 
    -              let lkup_key = ms_mod <$> moduleGraphNodeModSum s
    578 
    +              let lkup_key = moduleNodeInfoModule <$> mgNodeIsModule s
    395 579 
                       extra = (lkup_key >>= \key -> Map.lookup key boot_summaries)
    396 580
    397 581 
                   in Right $ DigraphNode s key $ out_edge_keys $
    ... ... @@ -423,12 +607,16 @@ newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a }
    423 607 
     mkNodeKey :: ModuleGraphNode -> NodeKey
    424 608 
     mkNodeKey = \case
    425 609 
       InstantiationNode _ iu -> NodeKey_Unit iu
    426 
    -  ModuleNode _ x -> NodeKey_Module $ msKey x
    610 
    +  ModuleNode _ x -> NodeKey_Module $ mnKey x
    427 611 
       LinkNode _ uid   -> NodeKey_Link uid
    428 612
    429 613 
     msKey :: ModSummary -> ModNodeKeyWithUid
    430 614 
     msKey ms = ModNodeKeyWithUid (ms_mnwib ms) (ms_unitid ms)
    431 615
    616 
    +mnKey :: ModuleNodeInfo -> ModNodeKeyWithUid
    617 
    +mnKey (ModuleNodeFixed key _) = key
    618 
    +mnKey (ModuleNodeCompile ms) = msKey ms
    619 
    +
    432 620 
     type ModNodeKey = ModuleNameWithIsBoot
    433 621
    434 622

  • compiler/GHC/Unit/State.hs
    ... ... @@ -1401,10 +1401,11 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..]
    1401 1401 
         merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do
    1402 1402 
           debugTraceMsg logger 2 $
    1403 1403 
               text "loading package database" <+> OsPath.pprOsPath db_path
    1404 
    -      forM_ (Set.toList override_set) $ \pkg ->
    1405 
    -          debugTraceMsg logger 2 $
    1406 
    -              text "package" <+> ppr pkg <+>
    1407 
    -              text "overrides a previously defined package"
    1404 
    +      when (log_verbosity (logFlags logger) >= 2) $
    1405 
    +        forM_ (Set.toList override_set) $ \pkg ->
    1406 
    +            debugTraceMsg logger 2 $
    1407 
    +                text "package" <+> ppr pkg <+>
    1408 
    +                text "overrides a previously defined package"
    1408 1409 
           return (pkg_map', prec_map')
    1409 1410 
          where
    1410 1411 
           db_map = mk_pkg_map db
    ... ... @@ -2382,4 +2383,3 @@ implicitPackageDeps dflags
    2382 2383 
        = [thUnitId | xopt TemplateHaskellQuotes dflags]
    2383 2384 
        -- TODO: Should also include `base` and `ghc-prim` if we use those implicitly, but
    2384 2385 
        -- it is possible to not depend on base (for example, see `ghc-prim`)
    2385 
    -

  • ghc/GHCi/UI.hs
    ... ... @@ -61,7 +61,7 @@ import qualified GHC
    61 61 
     import GHC ( LoadHowMuch(..), Target(..),  TargetId(..),
    62 62 
                  Resume, SingleStep, Ghc,
    63 63 
                  GetDocsFailure(..), pushLogHookM,
    64 
    -             getModuleGraph, handleSourceError, ms_mod )
    64 
    +             getModuleGraph, handleSourceError )
    65 65 
     import GHC.Driver.Main (hscParseModuleWithLocation, hscParseStmtWithLocation)
    66 66 
     import GHC.Hs.ImpExp
    67 67 
     import GHC.Hs
    ... ... @@ -1753,7 +1753,7 @@ editFile str =
    1753 1753 
     -- of those.
    1754 1754 
     chooseEditFile :: GHC.GhcMonad m => m String
    1755 1755 
     chooseEditFile =
    1756 
    -  do let hasFailed (GHC.ModuleNode _deps x) = fmap not $ isLoadedModSummary x
    1756 
    +  do let hasFailed (GHC.ModuleNode _deps x) = fmap not $ isLoadedModuleNode x
    1757 1757 
              hasFailed _ = return False
    1758 1758
    1759 1759 
          graph <- GHC.getModuleGraph
    ... ... @@ -1762,7 +1762,7 @@ chooseEditFile =
    1762 1762 
          let order g  = flattenSCCs $ filterToposortToModules $
    1763 1763 
                GHC.topSortModuleGraph True g Nothing
    1764 1764 
              pick xs  = case xs of
    1765 
    -                      x : _ -> GHC.ml_hs_file (GHC.ms_location x)
    1765 
    +                      x : _ -> GHC.ml_hs_file (GHC.moduleNodeInfoLocation x)
    1766 1766 
                           _     -> Nothing
    1767 1767
    1768 1768 
          case pick (order failed_graph) of
    ... ... @@ -2205,7 +2205,7 @@ setContextAfterLoad keep_ctxt (Just graph) = do
    2205 2205 
             (m:_) ->
    2206 2206 
               load_this m
    2207 2207 
      where
    2208 
    -   is_loaded (GHC.ModuleNode _ ms) = isLoadedModSummary ms
    2208 
    +   is_loaded (GHC.ModuleNode _ ms) = isLoadedModuleNode ms
    2209 2209 
        is_loaded _ = return False
    2210 2210
    2211 2211 
        findTarget mds t
    ... ... @@ -2214,13 +2214,13 @@ setContextAfterLoad keep_ctxt (Just graph) = do
    2214 2214 
             (m:_) -> Just m
    2215 2215
    2216 2216 
        (GHC.ModuleNode _ summary) `matches` Target { targetId = TargetModule m }
    2217 
    -        = if GHC.ms_mod_name summary == m then Just summary else Nothing
    2217 
    +        = if GHC.moduleNodeInfoModuleName summary == m then Just summary else Nothing
    2218 2218 
        (GHC.ModuleNode _ summary) `matches` Target { targetId = TargetFile f _ }
    2219 
    -        | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   =
    2219 
    +        | Just f' <- GHC.ml_hs_file (GHC.moduleNodeInfoLocation summary)   =
    2220 2220 
               if f == f' then Just summary else Nothing
    2221 2221 
        _ `matches` _ = Nothing
    2222 2222
    2223 
    -   load_this summary | m <- GHC.ms_mod summary = do
    2223 
    +   load_this summary | m <- GHC.moduleNodeInfoModule summary = do
    2224 2224 
             is_interp <- GHC.moduleIsInterpreted m
    2225 2225 
             dflags <- getDynFlags
    2226 2226 
             let star_ok = is_interp && not (safeLanguageOn dflags)
    ... ... @@ -2270,7 +2270,7 @@ keepPackageImports = filterM is_pkg_import
    2270 2270
    2271 2271
    2272 2272
    2273 
    -modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModSummary] -> LoadType -> m ()
    2273 
    +modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModuleNodeInfo] -> LoadType -> m ()
    2274 2274 
     modulesLoadedMsg ok mods load_type = do
    2275 2275 
       dflags <- getDynFlags
    2276 2276 
       when (verbosity dflags > 0) $ do
    ... ... @@ -2307,11 +2307,11 @@ modulesLoadedMsg ok mods load_type = do
    2307 2307 
                | otherwise       = "Failed"
    2308 2308
    2309 2309 
         mod_name mod = do
    2310 
    -        is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable mod
    2310 
    +        is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable (GHC.moduleNodeInfoModule mod)
    2311 2311 
             pure $ if is_interpreted
    2312 
    -               then ppr (GHC.ms_mod mod)
    2313 
    -               else ppr (GHC.ms_mod mod)
    2314 
    -                    <+> parens (text $ normalise $ msObjFilePath mod)
    2312 
    +               then ppr (GHC.moduleNodeInfoModule mod)
    2313 
    +               else ppr (GHC.moduleNodeInfoModule mod)
    2314 
    +                    <+> parens (text $ normalise $ (ml_obj_file (GHC.moduleNodeInfoLocation mod)))
    2315 2315 
                         -- Fix #9887
    2316 2316
    2317 2317 
     -- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors
    ... ... @@ -3376,10 +3376,10 @@ showModules = do
    3376 3376 
       let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)
    3377 3377 
       mapM_ show_one loaded_mods
    3378 3378
    3379 
    -getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
    3379 
    +getLoadedModules :: GHC.GhcMonad m => m [GHC.ModuleNodeInfo]
    3380 3380 
     getLoadedModules = do
    3381 3381 
       graph <- GHC.getModuleGraph
    3382 
    -  filterM isLoadedModSummary (GHC.mgModSummaries graph)
    3382 
    +  filterM isLoadedModuleNode (mapMaybe GHC.mgNodeIsModule (GHC.mgModSummaries' graph))
    3383 3383
    3384 3384 
     showBindings :: GHC.GhcMonad m => m ()
    3385 3385 
     showBindings = do
    ... ... @@ -3407,8 +3407,10 @@ showBindings = do
    3407 3407 
     printTyThing :: GHC.GhcMonad m => TyThing -> m ()
    3408 3408 
     printTyThing tyth = printForUser (pprTyThing showToHeader tyth)
    3409 3409
    3410 
    -isLoadedModSummary :: GHC.GhcMonad m => ModSummary -> m Bool
    3411 
    -isLoadedModSummary ms = GHC.isLoadedModule (ms_unitid ms) (ms_mod_name ms)
    3410 
    +isLoadedModuleNode :: GHC.GhcMonad m => GHC.ModuleNodeInfo -> m Bool
    3411 
    +isLoadedModuleNode ms =
    3412 
    +  let m = GHC.moduleNodeInfoModule ms
    3413 
    +  in GHC.isLoadedModule (moduleUnitId m) (moduleName m)
    3412 3414
    3413 3415 
     {-
    3414 3416 
     Note [Filter bindings]
    ... ... @@ -3697,7 +3699,7 @@ completeModule = wrapIdentCompleterMod $ \w -> do
    3697 3699 
       hsc_env <- GHC.getSession
    3698 3700 
       query <- liftIO $ hscUnitIndexQuery hsc_env
    3699 3701 
       let pkg_mods = allVisibleModules (hsc_units hsc_env) query
    3700 
    -  loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
    3702 
    +  loaded_mods <- liftM (map GHC.moduleNodeInfoModuleName) getLoadedModules
    3701 3703 
       return $ filter (w `isPrefixOf`)
    3702 3704 
             $ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods
    3703 3705
    ... ... @@ -3710,7 +3712,7 @@ completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
    3710 3712 
           return $ map iiModuleName imports
    3711 3713 
         _ -> do
    3712 3714 
           let pkg_mods = allVisibleModules (hsc_units hsc_env) query
    3713 
    -      loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
    3715 
    +      loaded_mods <- liftM (map GHC.moduleNodeInfoModuleName) getLoadedModules
    3714 3716 
           return $ loaded_mods ++ pkg_mods
    3715 3717 
       return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules
    3716 3718
    ... ... @@ -4360,11 +4362,11 @@ listModuleLine modl line = do
    4360 4362 
        graph <- GHC.getModuleGraph
    4361 4363 
        let this = GHC.mgLookupModule graph modl
    4362 4364 
        case this of
    4363 
    -     Nothing -> panic "listModuleLine"
    4364 
    -     Just summ -> do
    4365 
    +     Just (GHC.ModuleNodeCompile summ) -> do
    4365 4366 
                let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
    4366 4367 
                    loc = mkRealSrcLoc (mkFastString (filename)) line 0
    4367 4368 
                listAround (realSrcLocSpan loc) False
    4369 
    +     _ -> panic "listModuleLine"
    4368 4370
    4369 4371 
     -- | list a section of a source file around a particular SrcSpan.
    4370 4372 
     -- If the highlight flag is True, also highlight the span using

  • utils/haddock
    1 
    -Subproject commit bca637b3738490fed62f228ae4c90834a72de552
    1 
    +Subproject commit 2bf01c6a9dcf6ec54f5ce99b16a411d4b13f5be9

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help