Rodrigo Mesquita pushed to branch wip/romes/27461 at Glasgow Haskell Compiler / GHC

Commits:

1 changed file:

Changes:

  • compiler/GHC/Driver/Downsweep.hs
    ... ... @@ -5,8 +5,6 @@
    5 5 
     {-# LANGUAGE RecordWildCards #-}
    6 6 
     {-# LANGUAGE BlockArguments #-}
    7 7 
     {-# LANGUAGE ViewPatterns #-}
    8 
    -{-# LANGUAGE TypeFamilies #-}
    9 
    -{-# LANGUAGE FunctionalDependencies #-}
    10 8 
     module GHC.Driver.Downsweep
    11 9 
       ( downsweep
    12 10 
       , downsweepThunk
    ... ... @@ -148,6 +146,9 @@ See also Note [Downsweep Control Flow and Caching]
    148 146 
     -}
    149 147
    150 148 
     -----------------------------------------------------------------------------
    149 
    +-- * Top-level entry to downsweep
    150 
    +-----------------------------------------------------------------------------
    151 
    +
    151 152 
     --
    152 153 
     -- | Downsweep (dependency analysis) for --make mode
    153 154 
     --
    ... ... @@ -159,7 +160,7 @@ See also Note [Downsweep Control Flow and Caching]
    159 160 
     -- cache to avoid recalculating a module summary if the source is
    160 161 
     -- unchanged.
    161 162 
     --
    162 
    --- Downsweeping can start from scratch for from a given module graph. In the
    163 
    +-- Downsweeping can start from scratch or from a given module graph. In the
    163 164 
     -- latter case, the given graph is fully included in the resulting graph, even
    164 165 
     -- if parts of it are not reachable from any of the given roots. When an import
    165 166 
     -- is processed, the source of the imported module is not consulted if this
    ... ... @@ -231,6 +232,35 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo
    231 232 
         unitModuleNodes summaries uid hue =
    232 233 
           maybeToList (linkNodes summaries uid hue)
    233 234
    235 
    +    -- The linking plan for each module. If we need to do linking for a home unit
    236 
    +    -- then this function returns a graph node which depends on all the modules in the home unit.
    237 
    +
    238 
    +    -- At the moment nothing can depend on these LinkNodes.
    239 
    +    linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)
    240 
    +    linkNodes summaries uid hue =
    241 
    +      let dflags = homeUnitEnv_dflags hue
    242 
    +          ofile = outputFile_ dflags
    243 
    +
    244 
    +          unit_nodes :: [NodeKey]
    245 
    +          unit_nodes = map mkNodeKey (filter ((== uid) . mgNodeUnitId) summaries)
    246 
    +      -- Issue a warning for the confusing case where the user
    247 
    +      -- said '-o foo' but we're not going to do any linking.
    248 
    +      -- We attempt linking if either (a) one of the modules is
    249 
    +      -- called Main, or (b) the user said -no-hs-main, indicating
    250 
    +      -- that main() is going to come from somewhere else.
    251 
    +      --
    252 
    +          no_hs_main = gopt Opt_NoHsMain dflags
    253 
    +
    254 
    +          main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes
    255 
    +
    256 
    +          do_linking =  main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib || ghcLink dflags == LinkBytecodeLib
    257 
    +
    258 
    +      in if | isExecutableLink (ghcLink dflags) && isJust ofile && not do_linking ->
    259 
    +                Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags))
    260 
    +            -- This should be an error, not a warning (#10895).
    261 
    +            | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid))
    262 
    +            | otherwise  -> Nothing
    263 
    +
    234 264 
     -- | Calculate the module graph starting from a single ModSummary. The result is a
    235 265 
     -- thunk, which when forced will perform the downsweep. This is useful in oneshot
    236 266 
     -- mode where the module graph may never be needed.
    ... ... @@ -322,7 +352,32 @@ downsweepInstalledModules hsc_env mods = do
    322 352
    323 353 
         return (mkModuleGraph mg)
    324 354
    355 
    +-----------------------------------------------------------------------------
    356 
    +-- * Orchestrator: downsweepFromRootNodes
    357 
    +-----------------------------------------------------------------------------
    325 358
    359 
    +type ModSummaryCache = IORef ModSummaryCacheMap
    360 
    +type ImportsCache    = IORef ImportsCacheMap
    361 
    +
    362 
    +-- | A cache from file paths to the already summarised modules. The same file
    363 
    +-- can be used in multiple units so the map is actually also keyed by which
    364 
    +-- unit the file was used in.
    365 
    +--
    366 
    +-- We want to reuse ModSummaries as far as possible because the most expensive
    367 
    +-- part of downsweep is reading and parsing the headers.
    368 
    +--
    369 
    +-- See Note [Downsweep Control Flow and Caching]
    370 
    +type ModSummaryCacheMap
    371 
    +      -- The cache can't be keyed by 'Module' because that isn't sufficient to
    372 
    +      -- distinguish .hs from .hs-boot files. Use path+unit instead.
    373 
    +      = ( M.Map (UnitId, OsPath) (Either DriverMessages (ModSummary, SummProvenance)) )
    374 
    +
    375 
    +data SummProvenance
    376 
    +  -- | Constructed during this downsweep: trivially up to date
    377 
    +  = SummFresh
    378 
    +  -- | Carried over from a previous run: may be stale, must be hash-checked
    379 
    +  -- (and considered by -fforce-recomp)
    380 
    +  | SummOld
    326 381
    327 382 
     -- | Whether downsweep should use compiler or fixed nodes. Compile nodes are used
    328 383 
     -- by --make mode, and fixed nodes by oneshot mode.
    ... ... @@ -387,14 +442,9 @@ downsweepFromRootNodes hsc_env summ_cache imps_cache maybe_base_graph excl_mods
    387 442
    388 443 
         sec = initSourceErrorContext (hsc_dflags hsc_env)
    389 444
    390 
    -calcDeps :: ModSummary -> [(ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
    391 
    -calcDeps ms =
    392 
    -  -- Add a dependency on the HsBoot file if it exists
    393 
    -  -- This gets passed to the loopImports function which just ignores it if it
    394 
    -  -- can't be found.
    395 
    -  [(NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++
    396 
    -  [(lvl, b, c) | (lvl, b, c) <- msDeps ms ]
    397 
    -
    445 
    +--------------------------------------------------------------------------------
    446 
    +-- ** 'DownsweepM'
    447 
    +--------------------------------------------------------------------------------
    398 448
    399 449 
     type DownsweepM a = ReaderT DownsweepEnv IO a
    400 450 
     data DownsweepEnv = DownsweepEnv {
    ... ... @@ -405,29 +455,6 @@ data DownsweepEnv = DownsweepEnv {
    405 455 
         , _downsweep_excl_mods :: [ModuleName]
    406 456 
     }
    407 457
    408 
    -type ModSummaryCache = IORef ModSummaryCacheMap
    409 
    -type ImportsCache    = IORef ImportsCacheMap
    410 
    -
    411 
    --- | A cache from file paths to the already summarised modules. The same file
    412 
    --- can be used in multiple units so the map is actually also keyed by which
    413 
    --- unit the file was used in.
    414 
    ---
    415 
    --- We want to reuse ModSummaries as far as possible because the most expensive
    416 
    --- part of downsweep is reading and parsing the headers.
    417 
    ---
    418 
    --- See Note [Downsweep Control Flow and Caching]
    419 
    -type ModSummaryCacheMap
    420 
    -      -- The cache can't be keyed by 'Module' because that isn't sufficient to
    421 
    -      -- distinguish .hs from .hs-boot files. Use path+unit instead.
    422 
    -      = ( M.Map (UnitId, OsPath) (Either DriverMessages (ModSummary, SummProvenance)) )
    423 
    -
    424 
    -data SummProvenance
    425 
    -  -- | Constructed during this downsweep: trivially up to date
    426 
    -  = SummFresh
    427 
    -  -- | Carried over from a previous run: may be stale, must be hash-checked
    428 
    -  -- (and considered by -fforce-recomp)
    429 
    -  | SummOld
    430 
    -
    431 458 
     mkModSummaryCache :: [(ModSummary, SummProvenance)] -> ModSummaryCacheMap
    432 459 
     mkModSummaryCache summs = foldl' (flip (uncurry addModSummaryCache)) M.empty summs
    433 460
    ... ... @@ -471,6 +498,8 @@ loopUnits base_map homud = loopDownsweepNodes base_map . map (DSUnit h
    471 498 
     loopInstantiations  base_map       = loopDownsweepNodes base_map . map (uncurry DSInst)
    472 499 
     loopFromInteractive base_map m     = loopDownsweepNodes base_map . (:[]) . DSInteractive m
    473 500
    501 
    +--------------------------------------------------------------------------------
    502 
    +-- * Expanding 'DownsweepNode's into payload and node dependencies
    474 503 
     --------------------------------------------------------------------------------
    475 504
    476 505 
     -- | A 'DownsweepNode' is the basic block of the downsweep algorithm which
    ... ... @@ -530,7 +559,24 @@ expandModuleSummary ms = do -- Didn't work out what the imports mean yet, now do
    530 559 
         hsc_env <- asks downsweep_hsc_env
    531 560 
         let home_uid  = ms_unitid ms
    532 561 
             home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
    533 
    -    (final_deps, todo) <- fmap unzip $ forM (calcDeps ms) $ \(imp,mb_pkg,gwib) -> do
    562 
    +    (final_deps, todo) <- unzip <$> mapM (expandModImport home_uid home_unit) (calcDeps ms)
    563 
    +
    564 
    +    -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
    565 
    +    boot_todo <-
    566 
    +      if | HsBootFile <- ms_hsc_src ms
    567 
    +         -> do
    568 
    +            r <- downsweepSummarise home_unit NotBoot (noLoc $ ms_mod_name ms) NoPkgQual Nothing
    569 
    +            case r of
    570 
    +              FoundHome s -> pure [DSMod s]
    571 
    +              _           -> pure []
    572 
    +         | otherwise      -> pure []
    573 
    +
    574 
    +    return $ NSuccess
    575 
    +      ( ModuleNode (catMaybes final_deps) (ModuleNodeCompile ms)
    576 
    +      , boot_todo ++ concat todo
    577 
    +      )
    578 
    +  where
    579 
    +    expandModImport home_uid home_unit (imp,mb_pkg,gwib) = do
    534 580 
           let GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
    535 581 
               wanted_mod = L loc mod
    536 582 
           mb_s <- downsweepSummarise home_unit is_boot wanted_mod mb_pkg Nothing
    ... ... @@ -552,20 +598,13 @@ expandModuleSummary ms = do -- Didn't work out what the imports mean yet, now do
    552 598 
               ( Just $ mkModuleEdge imp (NodeKey_Module (mnKey s))
    553 599 
               , [DSMod s] )
    554 600
    555 
    -    -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
    556 
    -    boot_todo <-
    557 
    -      if | HsBootFile <- ms_hsc_src ms
    558 
    -         -> do
    559 
    -            r <- downsweepSummarise home_unit NotBoot (noLoc $ ms_mod_name ms) NoPkgQual Nothing
    560 
    -            case r of
    561 
    -              FoundHome s -> pure [DSMod s]
    562 
    -              _           -> pure []
    563 
    -         | otherwise      -> pure []
    564 
    -
    565 
    -    return $ NSuccess
    566 
    -      ( ModuleNode (catMaybes final_deps) (ModuleNodeCompile ms)
    567 
    -      , boot_todo ++ concat todo
    568 
    -      )
    601 
    +    calcDeps :: ModSummary -> [(ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
    602 
    +    calcDeps ms =
    603 
    +      -- Add a dependency on the HsBoot file if it exists
    604 
    +      -- This gets passed to the loopImports function which just ignores it if it
    605 
    +      -- can't be found.
    606 
    +      [(NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++
    607 
    +      [(lvl, b, c) | (lvl, b, c) <- msDeps ms ]
    569 608
    570 609 
     -- | Expand a 'ModuleNodeFixed' node
    571 610 
     -- NB: If you ever reach a Fixed node, everything under that also must be fixed.
    ... ... @@ -603,7 +642,7 @@ expandFixedModuleNode key loc = do
    603 642 
               pure $ Just $ DSMod (ModuleNodeFixed key loc)
    604 643 
             _otherwise ->
    605 644 
               -- If the finder fails, just keep going, there will be another
    606 
    -          -- error later.
    645 
    +          -- error later when we try to expand this dependency.
    607 646 
               pure Nothing
    608 647 
         mk_dep _ (Right uid_dep) = do
    609 648 
           -- Set active unit so that looking loopUnit finds the correct
    ... ... @@ -611,6 +650,19 @@ expandFixedModuleNode key loc = do
    611 650 
           let home_uid = mnkUnitId key
    612 651 
           pure (Just DSUnit{node_uid=uid_dep, home_context_uid=home_uid})
    613 652
    653 
    +    mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge
    654 
    +    mkFixedEdge (Left (lvl, key))  = mkModuleEdge lvl (NodeKey_Module key)
    655 
    +    mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid)
    656 
    +
    657 
    +    ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)]
    658 
    +    ifaceDeps deps =
    659 
    +      [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid)
    660 
    +      | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps)
    661 
    +      ] ++
    662 
    +      [ Right (tcImportLevel lvl, uid)
    663 
    +      | (lvl, uid) <- Set.toList (dep_direct_pkgs deps)
    664 
    +      ]
    665 
    +
    614 666 
     -- | Expand a unit id under the context of a certain home unit
    615 667 
     expandUnitNode :: UnitId {-^ @node_uid@ -} -> UnitId {-^ Home unit from where @node_uid@ was introduced -}
    616 668 
                    -> DownsweepM (MGRes (ModuleGraphNode, [DownsweepNode]))
    ... ... @@ -686,19 +738,8 @@ expandInteractiveImports imod imps = do
    686 738 
         node_type = ModuleNodeFixed key ml
    687 739
    688 740 
     --------------------------------------------------------------------------------
    689 
    -
    690 
    -mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge
    691 
    -mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key)
    692 
    -mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid)
    693 
    -
    694 
    -ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)]
    695 
    -ifaceDeps deps =
    696 
    -  [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid)
    697 
    -  | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps)
    698 
    -  ] ++
    699 
    -  [ Right (tcImportLevel lvl, uid)
    700 
    -  | (lvl, uid) <- Set.toList (dep_direct_pkgs deps)
    701 
    -  ]
    741 
    +-- * Constructing Module Summaries
    742 
    +--------------------------------------------------------------------------------
    702 743
    703 744 
     downsweepSummarise :: HomeUnit
    704 745 
                        -> IsBootInterface
    ... ... @@ -745,35 +786,6 @@ instantiationNodes uid unit_state = map (uid,) iuids_to_check
    745 786 
             , recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst
    746 787 
             ]
    747 788
    748 
    --- The linking plan for each module. If we need to do linking for a home unit
    749 
    --- then this function returns a graph node which depends on all the modules in the home unit.
    750 
    -
    751 
    --- At the moment nothing can depend on these LinkNodes.
    752 
    -linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)
    753 
    -linkNodes summaries uid hue =
    754 
    -  let dflags = homeUnitEnv_dflags hue
    755 
    -      ofile = outputFile_ dflags
    756 
    -
    757 
    -      unit_nodes :: [NodeKey]
    758 
    -      unit_nodes = map mkNodeKey (filter ((== uid) . mgNodeUnitId) summaries)
    759 
    -  -- Issue a warning for the confusing case where the user
    760 
    -  -- said '-o foo' but we're not going to do any linking.
    761 
    -  -- We attempt linking if either (a) one of the modules is
    762 
    -  -- called Main, or (b) the user said -no-hs-main, indicating
    763 
    -  -- that main() is going to come from somewhere else.
    764 
    -  --
    765 
    -      no_hs_main = gopt Opt_NoHsMain dflags
    766 
    -
    767 
    -      main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes
    768 
    -
    769 
    -      do_linking =  main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib || ghcLink dflags == LinkBytecodeLib
    770 
    -
    771 
    -  in if | isExecutableLink (ghcLink dflags) && isJust ofile && not do_linking ->
    772 
    -            Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags))
    773 
    -        -- This should be an error, not a warning (#10895).
    774 
    -        | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid))
    775 
    -        | otherwise  -> Nothing
    776 
    -
    777 789 
     getRootSummary ::
    778 790 
       [ModuleName] ->
    779 791 
       ModSummaryCache ->
    ... ... @@ -858,6 +870,10 @@ rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do
    858 870 
                   throwIO e
    859 871 
                 a -> pure a
    860 872
    873 
    +--------------------------------------------------------------------------------
    874 
    +-- * Check/validate properties and error out
    875 
    +--------------------------------------------------------------------------------
    876 
    +
    861 877 
     -- | This function checks then important property that if both p and q are home units
    862 878 
     -- then any dependency of p, which transitively depends on q is also a home unit.
    863 879 
     --
    ... ... @@ -905,6 +921,10 @@ checkHomeUnitsClosed ue
    905 921 
                           let todo'' = (depends Set.\\ done) `Set.union` todo'
    906 922 
                           in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo''
    907 923
    924 
    +--------------------------------------------------------------------------------
    925 
    +-- * Enable Code Gen for Template Haskell
    926 
    +--------------------------------------------------------------------------------
    927 
    +
    908 928 
     -- | Update the every ModSummary that is depended on
    909 929 
     -- by a module that needs template haskell. We enable codegen to
    910 930 
     -- the specified target, disable optimization and change the .hi
    ... ... @@ -1223,7 +1243,8 @@ Potential TODOS:
    1223 1243 
     -}
    1224 1244
    1225 1245 
     -----------------------------------------------------------------------------
    1226 
    --- Summarising modules
    1246 
    +-- * Pre-processing and Summarising and modules
    1247 
    +-----------------------------------------------------------------------------
    1227 1248
    1228 1249 
     -- We have two types of summarisation:
    1229 1250 
     --
    ... ... @@ -1639,6 +1660,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
    1639 1660 
       return PreprocessedImports {..}
    1640 1661
    1641 1662 
     --------------------------------------------------------------------------------
    1663 
    +-- * Generic traversal of iteratively-built graph: dfsBuild
    1664 
    +--------------------------------------------------------------------------------
    1642 1665
    1643 1666 
     -- | The result of expanding a node in 'dfsBuild'.
    1644 1667 
     data MGRes v
    ... ... @@ -1657,8 +1680,8 @@ data MGRes v
    1657 1680 
     -- graph by iteratively expanding a node into a payload and a list of children
    1658 1681 
     -- nodes to visit next.
    1659 1682 
     --
    1660 
    --- A node is NEVER visited/expanded more than once, as long as the the
    1661 
    --- node key @k@, computed from the node @n@, uniquely identifies that node.
    1683 
    +-- A node is NEVER visited/expanded more than once, as long as the node key
    1684 
    +-- @k@, computed from the node @n@, uniquely identifies that node.
    1662 1685 
     --
    1663 1686 
     -- The first argument @base_map@ is the starting set of already visited nodes
    1664 1687 
     -- (these nodes won't be expanded again!).
    ... ... @@ -1704,7 +1727,7 @@ dfsBuild base_map roots key expand = go roots (fromMaybe Map.empty base_map)
    1704 1727 
                    go ss
    1705 1728 
                       (Map.insert k NSkip        visited) -- Skip!
    1706 1729 
                  NSuccess (v,ns) ->
    1707 
    -               go (ns ++ ss {- todo: not use ++ here? -})
    1730 
    +               go (ns ++ ss)
    1708 1731 
                       (Map.insert k (NSuccess v) visited)
    1709 1732 
           where
    1710 1733 
             k = key s

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/commit/df2fc25cecae6aff5820518fb4a610724b6df41c at 1784201009