+section: ghc-pkg

+synopsis: Improve performance of `ghc-pkg list` command

+issues: #27275

+mrs: !16062

+

+description: {

+`ghc-pkg list` was quadratic in the number of packages due to an inefficient `closure` computation.

+We cache the set of seen packages, allowing us to speed up the `closure` computation, improving run-time

+for the commands `list`, `check`, `distrust`, `expose`, `hide`, `trust` and `unregister`.

+}

+      return (newTagUniqueGrimily uq tag)

+        liftIO $! mkSplitUniqSupplyGrimily tag

+        liftIO $! uniqFromTagGrimily tag

+  idTag i = let (tag, u) = unpkUniqueGrimily (getUnique i)

+  , let (c, u) = unpkUniqueGrimily (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits

+  (span1, src, meta, s) <- unITstring <$> lex_str strSpan strBuf strLen endBuf0

+  let span2 = mkPsSpan (psSpanStart span0) (psSpanEnd span1)

+  pure $ L span2 $ ITstring src meta{strMetaQualified = Just modName} s

+      L span1 (ITstring src meta s) -> (span1, src, meta, s)

+                               ; liftIO $! mkSplitUniqSupplyGrimily tag}

+                         ; liftIO $! uniqFromTagGrimily tag}

+          else let (c,u) = unpkUniqueGrimily (getUnique i)

+  -- | The 'TcM' plugins have been initialised and not yet stopped,

+  -- or there were no 'TcM' plugins to start with.

+  -- | There were 'TcM' plugins that were running, but they have been stopped.

+-- | A (possibly empty) collection of 'TcM' plugin @run@, @post-tc@ and

+-- @shutdown@ actions.

+-- Assumes the plugins (if any) have been already started and not yet stopped.

+  TcMPluginsUninitialised ->

+    pprPanic "TcM plugins have not been started" $

+      vcat [ text "If you are a GHC API user, make sure to use an appropriate 'TcMPluginHandling'"

+           , text "to ensure that TcM plugins (if any) are initialised before typechecking."

+           ]

+  TcMPluginsStopped ->

+    pprPanic "TcM plugins already stopped" $

+      vcat [ text "If you are a GHC API user and want to proceed to desugaring after typechecking,"

+           , text "make sure you are not using the 'StartAndStopTcMPlugins' 'TcMPluginHandling',"

+           , text "as that stops TcM plugins after typechecking."

+           ]

+    teardown =

+      -- Don't set 'tcg_plugins' to 'TcMPluginsStopped', as that should only

+      -- be used when there were 'TcM' plugins to start with (#27273).

+      return ()

+solverTcMPlugins =

+  tcmp_solvers . tcMPluginsRunActions . runningTcMPlugins

+rewriterTcMPlugins =

+  tcmp_rewriters . tcMPluginsRunActions . runningTcMPlugins

+defaultingTcMPlugins =

+  tcmp_defaulters . tcMPluginsRunActions . runningTcMPlugins

+holeFitTcMPlugins =

+  tcmp_hole_fits . tcMPluginsRunActions . runningTcMPlugins

+      ; liftIO $! uniqFromTagGrimily tag }

+      ; liftIO $! mkSplitUniqSupplyGrimily tag }

+takeUniqFromNameCache (NameCache c _) = uniqFromTagGrimily c

+        unpkUniqueGrimily,

+        newTagUnique, newTagUniqueGrimily,

+want to store the raw 'Char's. Working with the raw tags is done via the *Grimily

+       ; liftIO $! uniqFromTagGrimily tag }

+unpkUniqueGrimily :: Unique -> (Char, Word64)        -- The reverse

+newTagUniqueGrimily :: Unique -> Char -> Unique

+newTagUnique u c = newTagUniqueGrimily u (uniqueTag c)

+newTagUniqueGrimily u c = mkUniqueGrimilyWithTag c i where (_,i) = unpkUniqueGrimily u

+unpkUniqueGrimily (MkUnique u)

+{-# INLINE unpkUniqueGrimily #-}

+unpkUnique u = case unpkUniqueGrimily u of

+    case unpkUniqueGrimily u of

+    (tag, u) = unpkUniqueGrimily uniq

+        uniqFromTag, uniqFromTagGrimily,

+        mkSplitUniqSupply, mkSplitUniqSupplyGrimily,

+mkSplitUniqSupply ut = mkSplitUniqSupplyGrimily (uniqueTag ut)

+mkSplitUniqSupplyGrimily :: Char -> IO UniqSupply

+mkSplitUniqSupplyGrimily ut

+uniqFromTag !ut = uniqFromTagGrimily (uniqueTag ut)

+uniqFromTagGrimily :: Char -> IO Unique

+uniqFromTagGrimily !tag

+{-# NOINLINE uniqFromTagGrimily #-} -- We'll unbox everything, but we don't want to inline it

+module Main where

+

+-- base

+import Control.Monad

+import Control.Monad.IO.Class (liftIO)

+import System.Environment (getArgs)

+

+-- time

+import Data.Time (getCurrentTime)

+

+-- ghc

+import qualified GHC as GHC

+import qualified GHC.Core as GHC

+import qualified GHC.Data.StringBuffer as GHC

+import qualified GHC.Unit.Module.ModGuts as GHC

+import qualified GHC.Unit.Types as GHC

+

+--------------------------------------------------------------------------------

+

+main :: IO ()

+main = do

+    let inputSource = unlines

+          [ "module NumLitDesugaring where"

+          , "f :: Num a => a" -- !!! Succeeds if type signature is f :: Int

+          , "f = 1"

+          ]

+

+    void $ compileToCore "NumLitDesugaring" inputSource

+

+compileToCore :: String -> String -> IO [GHC.CoreBind]

+compileToCore modName inputSource = do

+    [libdir] <- getArgs

+    GHC.runGhc (Just libdir) $ do

+      (_ms, tcMod) <- typecheckSourceCode modName inputSource

+      dsMod <- GHC.desugarModule tcMod

+      return $ GHC.mg_binds $ GHC.dm_core_module dsMod

+

+typecheckSourceCode

+  :: GHC.GhcMonad m => String -> String -> m (GHC.ModSummary, GHC.TypecheckedModule)

+typecheckSourceCode modName inputSource = do

+    now <- liftIO getCurrentTime

+    df1 <- GHC.getSessionDynFlags

+    GHC.setSessionDynFlags $ df1 { GHC.backend = GHC.bytecodeBackend }

+    let target = GHC.Target

+               { GHC.targetId           = GHC.TargetFile (modName ++ ".hs") Nothing

+               , GHC.targetUnitId       = GHC.homeUnitId_ df1

+               , GHC.targetAllowObjCode = False

+               , GHC.targetContents     = Just (GHC.stringToStringBuffer inputSource, now)

+               }

+    GHC.setTargets [target]

+    void $ GHC.depanal [] False

+

+    ms <- GHC.getModSummary

+            (GHC.mkModule GHC.mainUnit (GHC.mkModuleName modName))

+    tm <- GHC.parseModule ms >>= GHC.typecheckModule GHC.NoTcMPlugins

+    return (ms, tm)

+test('T27273', [extra_run_opts(f'"{config.libdir}"')],

+               compile_and_run,

+               ['-package ghc'])

+.PHONY: Test27291

+Test27291:

+	$(CHECK_PPR)   $(LIBDIR) Test27291.hs

+	$(CHECK_EXACT) $(LIBDIR) Test27291.hs

+

+

+.PHONY: PprQualifiedStrings

+PprQualifiedStrings:

+	$(CHECK_PPR)   $(LIBDIR) PprQualifiedStrings.hs

+	$(CHECK_EXACT) $(LIBDIR) PprQualifiedStrings.hs

+{-# LANGUAGE MultilineStrings #-}

+{-# LANGUAGE QualifiedStrings #-}

+{-# LANGUAGE TemplateHaskell #-}

+

+-- These are harvested from ../qualified-strings

+

+module PprQualifiedStrings where

+

+import Data.Typeable (Typeable, typeOf)

+import qualified Example.ByteStringAscii as Ascii

+import qualified Example.ByteStringUtf8 as Utf8

+import qualified Example.Text as Text

+

+exprs :: IO ()

+exprs = do

+  inspect "I'm a String" -- would be an ambiguous type error with OverloadedStrings

+  inspect Text."I'm a Text"

+  inspect Ascii."I'm an ASCII bytestring: 語"

+  inspect Utf8."I'm a UTF8 bytestring: 語"

+

+  inspect """

+    I'm a multiline

+    String value

+    !

+  """

+

+  inspect Text."""

+    I'm a multiline

+    Text value

+    !

+  """

+

+  inspect Text .  """

+    I'm a multiline

+    Text value

+  """

+

+    inspect Text .

+      """

+      I'm a multiline

+      Text value

+      """

+

+pats :: IO ()

+pats = do

+  let text = Text."foo" :: Text

+  case text of

+    Text."foo" -> putStrLn "Text.\"foo\" matched"

+    _ -> putStrLn "Text.\"foo\" did not match"

+

+  let ascii = Ascii."語" :: ByteString

+  case ascii of

+    Ascii."語" -> putStrLn "Ascii.\"語\" matched"

+    _ -> putStrLn "Ascii.\"語\" did not match"

+

+  let utf = Utf8."語" :: ByteString

+  case utf of

+    Utf8."語" -> putStrLn "Utf8.\"語\" matched"

+    _ -> putStrLn "Utf8.\"語\" did not match"

+

+th :: IO ()

+th =

+  $(do

+      foldr (\stmt acc -> [| $stmt >> $acc |]) [| pure () |] $

+        [ [| inspect Text."I'm a Text" |]

+        , [| inspect Ascii."I'm an ASCII bytestring: 語" |]

+        , [| inspect Utf8."I'm a Utf8 bytestring: 語" |]

+        , [|

+            inspect Text."""

+              I'm a multiline

+              Text string

+            """

+          |]

+        ]

+   )

+{-# LANGUAGE ExplicitNamespaces #-}

+

+module Test27291

+    ( C(type ..)       -- exports class C and data family D

+    , C(data ..)       -- exports class C and method m

+    , D(type ..)       -- exports data family D

+    , type T (..)      -- exports type T and all its data constructors D, D2

+    , type T (type ..) -- exports type T

+    , type K (type ..) -- exports type K and its constructor K1

+    ) where

+

+import Control.Applicative qualified as A (type Applicative (data ..))

+import Data.Either qualified as E (type Either (data ..))

+

+import Data.Bool (data True (..))

+import Data.Bool (data True( data .. ) )

+import Data.Bool (data True( type ..))

+

+import DodgyImports03_helper (C(  .. ))

+import DodgyImports03_helper (C  (data .. ))

+import DodgyImports03_helper (C(  type ..) )

+

+import DodgyImports03_helper (T ( .. ) )

+import DodgyImports03_helper (T(data ..))

+import DodgyImports03_helper (T(type ..))

+

+import Control.Applicative (type Applicative (type ..))  -- dodgy: no associated types

+import Data.Either (type Either (type ..))               -- dodgy: not a class

+

+import Data.Proxy (type Proxy(data ..))                  -- ok

+import Data.Proxy (type Proxy(type ..))                  -- dodgy: not a class

+

+import T25901_sub_g_helper qualified as T1 (T (data ..)) -- T and MkT

+import T25901_sub_g_helper qualified as T2 (T (type ..)) -- T only

+import T25901_sub_g_helper qualified as T3 (type T (..)) -- T and MkT

+test('Test27291', [ignore_stderr, req_ppr_deps], makefile_test, ['Test27291'])

+test('PprQualifiedStrings', [ignore_stderr,req_ppr_deps], makefile_test, ['PprQualifiedStrings'])

+  exact (HsQualLit _ (QualLit _ modu (HsQualString src fs))) = do

+    modu' <- markAnnotated modu

+    printStringAdvanceA "."

+    printSourceTextAA src (show (unpackFS fs))

+    return (HsQualLit noExtField (QualLit noExtField modu' (HsQualString src fs)))

+

+    ns_spec' <- markAnnotated ns_spec

+      trans_broken_pkgs = brokenPackages not_broken_pkgs

+-- | Compute the set of transitive broken packages.

+--

+-- A package is assumed to be broken if any of its dependencies is not

+-- found in the 'db_stack' after a transitive reduction.

+brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]

+brokenPackages db_stack = go Set.empty db_stack

+  where

+    go avail_ids not_avail =

+      case partition (depsAvailable avail_ids) not_avail of

+        ([],        not_avail') -> not_avail'

+        (new_avail, not_avail') -> go (add new_avail avail_ids) not_avail'

+    add new_avail avail_ids =

+      foldl' (flip Set.insert) avail_ids (map installedUnitId new_avail)

+    depsAvailable :: Set.Set UnitId -> InstalledPackageInfo -> Bool

+    depsAvailable pids pkg = all (`Set.member` pids) (depends pkg)

+      -- we want mutually recursive groups of package to show up

+      -- as broken. (#1750)