Teo Camarasu pushed to branch wip/T26925 at Glasgow Haskell Compiler / GHC

Commits:

3 changed files:

Changes:

  • testsuite/tests/count-deps/Makefile
    ... ... @@ -23,3 +23,8 @@ count-deps-parser:
    23 23 
     count-deps-ast:
    24 24 
     	$(COUNT_DEPS) $(LIBDIR) "ghc" "Language.Haskell.Syntax" | tee out
    25 25 
     	cat out | tail -n +2 | wc -l > SIZE
    26 
    +
    27 
    +.PHONY: count-deps-critical-path-ghc-internal
    28 
    +count-deps-critical-path-ghc-internal:
    29 
    +	$(COUNT_DEPS) $(LIBDIR) "ghc-internal" | tee out
    30 
    +	cat out | tail -n +2 | wc -l > SIZE

  • testsuite/tests/count-deps/all.T
    1 1 
     test('CountDepsAst', [stat_from_file('deps', 100, 'SIZE'), req_hadrian_deps(["test:count-deps"])], makefile_test, ['count-deps-ast'])
    2 2 
     test('CountDepsParser', [stat_from_file('deps', 100, 'SIZE'), req_hadrian_deps(["test:count-deps"])], makefile_test, ['count-deps-parser'])
    3 
    +test('CountDepsGhcInternalCriticalPath', [stat_from_file('deps', 100, 'SIZE'), req_hadrian_deps(["test:count-deps"])], makefile_test, ['count-deps-critical-path-ghc-internal'])

  • utils/count-deps/Main.hs
    ... ... @@ -14,9 +14,14 @@ import System.Environment
    14 14 
     import GHC.Unit.Module.Deps
    15 15 
     import GHC.Unit.State
    16 16 
     import GHC.Unit.Info
    17 
    +import GHC.Unit.Types
    17 18 
     import GHC.Data.FastString
    18 19 
     import Data.Map.Strict qualified as Map
    20 
    +import Data.Map.Lazy qualified as Lazy.Map
    19 21 
     import Data.Set qualified as Set
    22 
    +import Data.Maybe
    23 
    +import Data.List (maximumBy)
    24 
    +import Data.Ord (comparing)
    20 25
    21 26 
     -- Example invocation:
    22 27 
     --  inplace/bin/count-deps `inplace/bin/ghc-stage2 --print-libdir` ghc "GHC.Parser"
    ... ... @@ -24,8 +29,13 @@ main :: IO ()
    24 29 
     main = do
    25 30 
       args <- getArgs
    26 31 
       case args of
    27 
    -    [libdir, packageName, modName, "--dot"] -> printDeps libdir packageName modName True
    28 
    -    [libdir, packageName, modName] -> printDeps libdir packageName modName False
    32 
    +    [libdir, packageName, "--dot"] -> printDep libdir packageName Nothing True
    33 
    +    [libdir, packageName, "--crit-path"] -> do
    34 
    +      modgraph <- calcDeps Nothing packageName libdir
    35 
    +      let modgraph' = Map.map (map gwib_mod . filter ((/=) IsBoot . gwib_isBoot)) modgraph
    36 
    +      mapM_ putStrLn $ criticalPath modgraph'
    37 
    +    [libdir, packageName, modName, "--dot"] -> printDeps libdir packageName (Just modName) True
    38 
    +    [libdir, packageName, modName] -> printDeps libdir packageName (Just modName) False
    29 39 
         _ -> fail "usage: count-deps libdir package module [--dot]"
    30 40
    31 41 
     dotSpec :: String -> Map.Map String [String] -> String
    ... ... @@ -35,23 +45,23 @@ dotSpec name g =
    35 45 
       where
    36 46 
         f acc k ns = acc ++ concat ["  " ++ show k ++ " -> " ++ show n ++ ";\n" | n <- ns]
    37 47
    38 
    -printDeps :: String -> String -> String -> Bool -> IO ()
    48 
    +printDeps :: String -> String -> Maybe String -> Bool -> IO ()
    39 49 
     printDeps libdir packageName modName dot = do
    40 50 
       modGraph <-
    41 
    -    Map.map (map moduleNameString) .
    42 
    -      Map.mapKeys moduleNameString <$> calcDeps (Just modName) packageName libdir
    51 
    +    Map.map (map (moduleNameString . gwib_mod)) .
    52 
    +      Map.mapKeys (moduleNameString) <$> calcDeps modName packageName libdir
    43 53 
       if not dot then
    44 54 
         do
    45 55 
           let modules = Map.keys modGraph
    46 
    -      putStrLn $ "Found " ++ modName ++ " module dependencies"
    56 
    +      putStrLn $ "Found " ++ fromMaybe "" modName ++ " module dependencies"
    47 57 
           forM_ modules putStrLn
    48 58 
       else
    49 59 
         -- * Copy the digraph output to a file ('deps.dot' say)
    50 60 
         -- * To render it, use a command along the lines of
    51 61 
         --   'tred deps.dot > deps-tred.dot && dot -Tpdf -o deps.pdf deps-tred.dot'
    52 
    -    putStr $ dotSpec modName modGraph
    62 
    +    putStr $ dotSpec (fromMaybe "" modName) modGraph
    53 63
    54 
    -calcDeps :: Maybe String -> String -> FilePath -> IO (Map.Map ModuleName [ModuleName])
    64 
    +calcDeps :: Maybe String -> String -> FilePath -> IO (Map.Map ModuleName [ModuleNameWithIsBoot])
    55 65 
     calcDeps mmodName packageName libdir =
    56 66 
       defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
    57 67 
         runGhc (Just libdir) $ do
    ... ... @@ -75,7 +85,7 @@ calcDeps mmodName packageName libdir =
    75 85 
         -- Source imports are only guaranteed to show up in the 'mi_deps'
    76 86 
         -- of modules that import them directly and don’t propagate
    77 87 
         -- transitively so we loop.
    78 
    -    loop :: UnitId -> HscEnv -> Map.Map ModuleName [ModuleName] -> [ModuleName] -> Ghc (Map.Map ModuleName [ModuleName])
    88 
    +    loop :: UnitId -> HscEnv -> Map.Map ModuleName [ModuleNameWithIsBoot] -> [ModuleName] -> Ghc (Map.Map ModuleName [ModuleNameWithIsBoot])
    79 89 
         loop unitId env modules (m : ms) =
    80 90 
           if m `Map.member` modules
    81 91 
             then loop unitId env modules ms
    ... ... @@ -83,11 +93,36 @@ calcDeps mmodName packageName libdir =
    83 93 
               mi <- liftIO $ hscGetModuleInterface env (mkModule unitId m)
    84 94 
               let deps = modDeps mi
    85 95 
               modules <- return $ Map.insert m [] modules
    86 
    -          loop unitId env (Map.insert m deps modules) $ ms ++ filter (not . (`Map.member` modules)) deps
    96 
    +          loop unitId env (Map.insert m deps modules) $ ms ++ filter (not . (`Map.member` modules)) (map gwib_mod deps)
    87 97 
         loop _ _ modules [] = return modules
    88 98
    89 99 
         mkModule :: UnitId -> ModuleName -> Module
    90 100 
         mkModule unitId = Module (RealUnit $ Definite unitId)
    91 101
    92 
    -    modDeps :: ModIface -> [ModuleName]
    93 
    -    modDeps mi = map (gwib_mod . (\(_, _, mn) -> mn)) $ Set.toList $ dep_direct_mods (mi_deps mi)
    102 
    +    modDeps :: ModIface -> [ModuleNameWithIsBoot]
    103 
    +    modDeps mi = map (\(_, _, mn) -> mn) $ Set.toList $ dep_direct_mods (mi_deps mi)
    104 
    +
    105 
    +criticalPath :: Map.Map ModuleName [ModuleName] -> [String]
    106 
    +criticalPath modules = crit top
    107 
    +  where
    108 
    +    -- Calculate the rank of each module
    109 
    +    -- The rank of a vertex v is the maximum rank of its children + 1
    110 
    +    -- We crucially use laziness to give us a nice memoized construction.
    111 
    +    rank :: Map.Map ModuleName Int
    112 
    +    rank = Lazy.Map.fromList
    113 
    +      [ (k, 1 + safeMax (mapMaybe (\d -> Map.lookup d rank) deps))
    114 
    +        | (k, deps) <- Map.toList modules
    115 
    +      ]
    116 
    +    top = fst . maximumBy (comparing snd) $ Lazy.Map.toList rank
    117 
    +    -- The critical path starts with the module of highest rank
    118 
    +    -- and then we walk down the tree taking the module of maximum rank at each step.
    119 
    +    crit x = case deps of
    120 
    +       [] -> []
    121 
    +       _ ->
    122 
    +         let m = fst (maximumBy (comparing snd) depsRank)
    123 
    +         in moduleNameString m:crit m
    124 
    +      where
    125 
    +        depsRank = map (\n -> (n, fromMaybe 0 (Map.lookup n rank))) deps
    126 
    +        deps = fromMaybe [] $ Map.lookup x modules
    127 
    +    safeMax [] = 0
    128 
    +    safeMax xs = maximum xs

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