Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC

Commits:

15 changed files:

Changes:

  • changelog.d/ghc-pkg-faster-closure
    1 
    +section: ghc-pkg
    2 
    +synopsis: Improve performance of `ghc-pkg list` command
    3 
    +issues: #27275
    4 
    +mrs: !16062
    5 
    +
    6 
    +description: {
    7 
    +`ghc-pkg list` was quadratic in the number of packages due to an inefficient `closure` computation.
    8 
    +We cache the set of seen packages, allowing us to speed up the `closure` computation, improving run-time
    9 
    +for the commands `list`, `check`, `distrust`, `expose`, `hide`, `trust` and `unregister`.
    10 
    +}

  • compiler/GHC/CmmToLlvm/Base.hs
    ... ... @@ -318,7 +318,7 @@ instance DSM.MonadGetUnique LlvmM where
    318 318 
         tag <- getEnv envTag
    319 319 
         liftUDSMT $! do
    320 320 
           uq <- DSM.getUniqueM
    321 
    -      return (newTagUniqueGrimly uq tag)
    321 
    +      return (newTagUniqueGrimily uq tag)
    322 322
    323 323 
     -- | Lifting of IO actions. Not exported, as we want to encapsulate IO.
    324 324 
     liftIO :: IO a -> LlvmM a

  • compiler/GHC/Core/Opt/Monad.hs
    ... ... @@ -175,11 +175,11 @@ instance MonadPlus CoreM
    175 175 
     instance MonadUnique CoreM where
    176 176 
         getUniqueSupplyM = do
    177 177 
             tag <- read cr_uniq_tag
    178 
    -        liftIO $! mkSplitUniqSupplyGrimly tag
    178 
    +        liftIO $! mkSplitUniqSupplyGrimily tag
    179 179
    180 180 
         getUniqueM = do
    181 181 
             tag <- read cr_uniq_tag
    182 
    -        liftIO $! uniqFromTagGrimly tag
    182 
    +        liftIO $! uniqFromTagGrimily tag
    183 183
    184 184 
     runCoreM :: HscEnv
    185 185 
              -> RuleBase

  • compiler/GHC/HsToCore/Foreign/JavaScript.hs
    ... ... @@ -144,7 +144,7 @@ mkFExportJSBits platform c_nm maybe_target arg_htys res_hty is_IO_res_ty _cconv
    144 144 
                    | otherwise       = unpackHObj res_hty
    145 145
    146 146 
       header_bits = maybe mempty idTag maybe_target
    147 
    -  idTag i = let (tag, u) = unpkUniqueGrimly (getUnique i)
    147 
    +  idTag i = let (tag, u) = unpkUniqueGrimily (getUnique i)
    148 148 
                 in  CHeader (char tag <> word64 u)
    149 149
    150 150 
       normal_args = map (\(nm,_ty,_,_) -> nm) arg_info

  • compiler/GHC/Iface/Binary.hs
    ... ... @@ -707,7 +707,7 @@ putName BinSymbolTable{
    707 707 
                    bin_symtab_next = symtab_next }
    708 708 
             bh name
    709 709 
       | isKnownKeyName name
    710 
    -  , let (c, u) = unpkUniqueGrimly (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
    710 
    +  , let (c, u) = unpkUniqueGrimily (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
    711 711 
       = -- assert (u < 2^(22 :: Int))
    712 712 
         put_ bh (0x80000000
    713 713 
                  .|. (fromIntegral (ord c) `shiftL` 22)

  • compiler/GHC/Stg/Pipeline.hs
    ... ... @@ -66,9 +66,9 @@ newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }
    66 66
    67 67 
     instance MonadUnique StgM where
    68 68 
       getUniqueSupplyM = StgM $ do { tag <- ask
    69 
    -                               ; liftIO $! mkSplitUniqSupplyGrimly tag}
    69 
    +                               ; liftIO $! mkSplitUniqSupplyGrimily tag}
    70 70 
       getUniqueM = StgM $ do { tag <- ask
    71 
    -                         ; liftIO $! uniqFromTagGrimly tag}
    71 
    +                         ; liftIO $! uniqFromTagGrimily tag}
    72 72
    73 73 
     runStgM :: UniqueTag -> StgM a -> IO a
    74 74 
     runStgM mask (StgM m) = runReaderT m (uniqueTag mask)

  • compiler/GHC/StgToJS/Ids.hs
    ... ... @@ -130,7 +130,7 @@ makeIdentForId i num id_type current_module = name ident
    130 130 
             -- unique suffix for non-exported Ids
    131 131 
           , if exported
    132 132 
               then mempty
    133 
    -          else let (c,u) = unpkUniqueGrimly (getUnique i)
    133 
    +          else let (c,u) = unpkUniqueGrimily (getUnique i)
    134 134 
                    in mconcat [BSC.pack ['_',c,'_'], word64BS u]
    135 135 
           ]
    136 136
    ... ... @@ -235,4 +235,3 @@ declVarsForId i = case typeSize (idType i) of
    235 235 
       0 -> return mempty
    236 236 
       1 -> decl <$> identForId i
    237 237 
       s -> mconcat <$> mapM (\n -> decl <$> identForIdN i n) [1..s]
    238 
    -

  • compiler/GHC/Tc/Types.hs
    ... ... @@ -1250,14 +1250,17 @@ emptyTcMPluginsShutdown = TcMPluginsShutdown
    1250 1250 
     data TcMPluginsState
    1251 1251 
       -- | The 'TcM' plugins have not been started.
    1252 1252 
       = TcMPluginsUninitialised
    1253 
    -  -- | The 'TcM' plugins have been initialised and not yet stopped.
    1253 
    +  -- | The 'TcM' plugins have been initialised and not yet stopped,
    1254 
    +  -- or there were no 'TcM' plugins to start with.
    1254 1255 
       --
    1255 1256 
       -- We may be in the middle of typechecker, or have finished typechecking
    1256 1257 
       -- and be in the middle of desugaring.
    1257 1258 
       | TcMPluginsRunning !RunningTcMPlugins
    1258 
    -  -- | The 'TcM' plugins have been stopped.
    1259 
    +  -- | There were 'TcM' plugins that were running, but they have been stopped.
    1259 1260 
       | TcMPluginsStopped
    1260 1261
    1262 
    +-- | A (possibly empty) collection of 'TcM' plugin @run@, @post-tc@ and
    1263 
    +-- @shutdown@ actions.
    1261 1264 
     data RunningTcMPlugins =
    1262 1265 
       RunningTcMPlugins
    1263 1266 
         { rtcmp_run      :: TcMPluginsRun
    ... ... @@ -1281,11 +1284,20 @@ tcMPluginsShutdownActions = rtcmp_shutdown
    1281 1284
    1282 1285 
     -- | Retrieve the 'TcM' plugins from a 'TcMPluginsState'.
    1283 1286 
     --
    1284 
    --- Assumes the plugins have been already started and not yet stopped.
    1287 
    +-- Assumes the plugins (if any) have been already started and not yet stopped.
    1285 1288 
     runningTcMPlugins
    1286 1289 
        :: HasDebugCallStack
    1287 1290 
        => TcMPluginsState -> RunningTcMPlugins
    1288 1291 
     runningTcMPlugins = \case
    1289 
    -  TcMPluginsUninitialised -> panic "runningTcMPlugins: TcM plugins not started"
    1290 
    -  TcMPluginsStopped -> panic "runningTcMPlugins: TcM plugins already stopped"
    1292 
    +  TcMPluginsUninitialised ->
    1293 
    +    pprPanic "TcM plugins have not been started" $
    1294 
    +      vcat [ text "If you are a GHC API user, make sure to use an appropriate 'TcMPluginHandling'"
    1295 
    +           , text "to ensure that TcM plugins (if any) are initialised before typechecking."
    1296 
    +           ]
    1297 
    +  TcMPluginsStopped ->
    1298 
    +    pprPanic "TcM plugins already stopped" $
    1299 
    +      vcat [ text "If you are a GHC API user and want to proceed to desugaring after typechecking,"
    1300 
    +           , text "make sure you are not using the 'StartAndStopTcMPlugins' 'TcMPluginHandling',"
    1301 
    +           , text "as that stops TcM plugins after typechecking."
    1302 
    +           ]
    1291 1303 
       TcMPluginsRunning plugins -> plugins

  • compiler/GHC/Tc/Utils/Monad.hs
    ... ... @@ -790,9 +790,10 @@ withoutTcMPlugins thing_inside = do
    790 790 
           tcg_env <- getGblEnv
    791 791 
           writeTcRef (tcg_plugins tcg_env) $
    792 792 
             TcMPluginsRunning emptyRunningTcMPlugins
    793 
    -    teardown = do
    794 
    -      tcg_env <- getGblEnv
    795 
    -      writeTcRef (tcg_plugins tcg_env) TcMPluginsStopped
    793 
    +    teardown =
    794 
    +      -- Don't set 'tcg_plugins' to 'TcMPluginsStopped', as that should only
    795 
    +      -- be used when there were 'TcM' plugins to start with (#27273).
    796 
    +      return ()
    796 797
    797 798 
     -- | Initialise 'TcM' plugins.
    798 799 
     initTcMPlugins :: HscEnv -> TcM ()
    ... ... @@ -946,32 +947,20 @@ shutdownTcMPlugins = \case
    946 947 
           runPluginShutdowns (tcs ++ defs)
    947 948
    948 949 
     solverTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [TcPluginSolver]
    949 
    -solverTcMPlugins = \case
    950 
    -  TcMPluginsUninitialised -> panic "solverTcMPlugins: TcM plugins not started"
    951 
    -  TcMPluginsStopped -> panic "solverTcMPlugins: TcM plugins already stopped"
    952 
    -  TcMPluginsRunning plugins ->
    953 
    -    tcmp_solvers (tcMPluginsRunActions plugins)
    950 
    +solverTcMPlugins =
    951 
    +  tcmp_solvers . tcMPluginsRunActions . runningTcMPlugins
    954 952
    955 953 
     rewriterTcMPlugins :: HasDebugCallStack => TcMPluginsState -> UniqFM TyCon [TcPluginRewriter]
    956 
    -rewriterTcMPlugins = \case
    957 
    -  TcMPluginsUninitialised -> panic "rewriterTcMPlugins: TcM plugins not started"
    958 
    -  TcMPluginsStopped -> panic "rewriterTcMPlugins: TcM plugins already stopped"
    959 
    -  TcMPluginsRunning plugins ->
    960 
    -    tcmp_rewriters (tcMPluginsRunActions plugins)
    954 
    +rewriterTcMPlugins =
    955 
    +  tcmp_rewriters . tcMPluginsRunActions . runningTcMPlugins
    961 956
    962 957 
     defaultingTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [FillDefaulting]
    963 
    -defaultingTcMPlugins = \case
    964 
    -  TcMPluginsUninitialised -> panic "defaultingTcMPlugins: TcM plugins not started"
    965 
    -  TcMPluginsStopped -> panic "defaultingTcMPlugins: TcM plugins already stopped"
    966 
    -  TcMPluginsRunning plugins ->
    967 
    -    tcmp_defaulters (tcMPluginsRunActions plugins)
    958 
    +defaultingTcMPlugins =
    959 
    +  tcmp_defaulters . tcMPluginsRunActions . runningTcMPlugins
    968 960
    969 961 
     holeFitTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [HoleFitPlugin]
    970 
    -holeFitTcMPlugins = \case
    971 
    -  TcMPluginsUninitialised -> panic "holeFitTcMPlugins: TcM plugins not started"
    972 
    -  TcMPluginsStopped -> panic "holeFitTcMPlugins: TcM plugins already stopped"
    973 
    -  TcMPluginsRunning plugins ->
    974 
    -    tcmp_hole_fits (tcMPluginsRunActions plugins)
    962 
    +holeFitTcMPlugins =
    963 
    +  tcmp_hole_fits . tcMPluginsRunActions . runningTcMPlugins
    975 964
    976 965 
     {-
    977 966 
     ************************************************************************
    ... ... @@ -1008,13 +997,13 @@ newUnique :: TcRnIf gbl lcl Unique
    1008 997 
     newUnique
    1009 998 
      = do { env <- getEnv
    1010 999 
           ; let tag = env_ut env
    1011 
    -      ; liftIO $! uniqFromTagGrimly tag }
    1000 
    +      ; liftIO $! uniqFromTagGrimily tag }
    1012 1001
    1013 1002 
     newUniqueSupply :: TcRnIf gbl lcl UniqSupply
    1014 1003 
     newUniqueSupply
    1015 1004 
      = do { env <- getEnv
    1016 1005 
           ; let tag = env_ut env
    1017 
    -      ; liftIO $! mkSplitUniqSupplyGrimly tag }
    1006 
    +      ; liftIO $! mkSplitUniqSupplyGrimily tag }
    1018 1007
    1019 1008 
     cloneLocalName :: Name -> TcM Name
    1020 1009 
     -- Make a fresh Internal name with the same OccName and SrcSpan

  • compiler/GHC/Types/Name/Cache.hs
    ... ... @@ -122,7 +122,7 @@ data NameCache = NameCache
    122 122 
     type OrigNameCache   = ModuleEnv (OccEnv Name)
    123 123
    124 124 
     takeUniqFromNameCache :: NameCache -> IO Unique
    125 
    -takeUniqFromNameCache (NameCache c _) = uniqFromTagGrimly c
    125 
    +takeUniqFromNameCache (NameCache c _) = uniqFromTagGrimily c
    126 126
    127 127 
     lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
    128 128 
     lookupOrigNameCache nc mod occ = lookup_infinite <|> lookup_normal

  • compiler/GHC/Types/Unique.hs
    ... ... @@ -38,12 +38,12 @@ module GHC.Types.Unique (
    38 38 
             mkUniqueIntGrimily,
    39 39 
             getKey,
    40 40 
             mkUnique, unpkUnique,
    41 
    -        unpkUniqueGrimly,
    41 
    +        unpkUniqueGrimily,
    42 42 
             mkUniqueInt,
    43 43 
             eqUnique, ltUnique,
    44 44 
             incrUnique, stepUnique,
    45 45
    46 
    -        newTagUnique, newTagUniqueGrimly,
    46 
    +        newTagUnique, newTagUniqueGrimily,
    47 47 
             nonDetCmpUnique,
    48 48 
             isValidKnownKeyUnique,
    49 49
    ... ... @@ -99,7 +99,7 @@ Note [Performance implications of UniqueTag]
    99 99 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    100 100 
     The UniqueTag ADT is meant to be ephemeral and eliminated by the simplifier,
    101 101 
     so for long term storage (i.e. in monadic environments or data structures) we
    102 
    -want to store the raw 'Char's. Working with the raw tags is done via the *Grimly
    102 
    +want to store the raw 'Char's. Working with the raw tags is done via the *Grimily
    103 103 
     class of functions
    104 104
    105 105 
     For instance, if we are generating a unique for a concrete tag, we should use
    ... ... @@ -116,7 +116,7 @@ newUnique
    116 116 
            ; liftIO $! uniqFromTag tag }
    117 117
    118 118 
     Prefer `env_ut :: Char` and
    119 
    -       ; liftIO $! uniqFromTagGrimly tag }
    119 
    +       ; liftIO $! uniqFromTagGrimily tag }
    120 120
    121 121 
     -}
    122 122
    ... ... @@ -295,7 +295,7 @@ The stuff about unique *supplies* is handled further down this module.
    295 295 
     -}
    296 296
    297 297 
     unpkUnique :: Unique -> (UniqueTag, Word64)        -- The reverse
    298 
    -unpkUniqueGrimly :: Unique -> (Char, Word64)        -- The reverse
    298 
    +unpkUniqueGrimily :: Unique -> (Char, Word64)        -- The reverse
    299 299
    300 300 
     mkUniqueGrimily :: Word64 -> Unique                -- A trap-door for UniqSupply
    301 301 
     getKey          :: Unique -> Word64                -- for Var
    ... ... @@ -303,7 +303,7 @@ getKey :: Unique -> Word64 -- for Var
    303 303 
     incrUnique   :: Unique -> Unique
    304 304 
     stepUnique   :: Unique -> Word64 -> Unique
    305 305 
     newTagUnique :: Unique -> UniqueTag -> Unique
    306 
    -newTagUniqueGrimly :: Unique -> Char -> Unique
    306 
    +newTagUniqueGrimily :: Unique -> Char -> Unique
    307 307
    308 308 
     mkUniqueGrimily = MkUnique
    309 309
    ... ... @@ -323,9 +323,9 @@ maxLocalUnique :: Unique
    323 323 
     maxLocalUnique = mkLocalUnique uniqueMask
    324 324
    325 325 
     -- newTagUnique changes the "domain" of a unique to a different char
    326 
    -newTagUnique u c = newTagUniqueGrimly u (uniqueTag c)
    326 
    +newTagUnique u c = newTagUniqueGrimily u (uniqueTag c)
    327 327
    328 
    -newTagUniqueGrimly u c = mkUniqueGrimilyWithTag c i where (_,i) = unpkUniqueGrimly u
    328 
    +newTagUniqueGrimily u c = mkUniqueGrimilyWithTag c i where (_,i) = unpkUniqueGrimily u
    329 329
    330 330 
     -- | Bitmask that has zeros for the tag bits and ones for the rest.
    331 331 
     uniqueMask :: Word64
    ... ... @@ -368,7 +368,7 @@ mkUniqueIntGrimily = MkUnique . intToWord64
    368 368
    369 369 
     {-# INLINE mkUniqueIntGrimily #-}
    370 370
    371 
    -unpkUniqueGrimly (MkUnique u)
    371 
    +unpkUniqueGrimily (MkUnique u)
    372 372 
       = let
    373 373 
             -- The potentially truncating use of fromIntegral here is safe
    374 374 
             -- because the argument is just the tag bits after shifting.
    ... ... @@ -376,10 +376,10 @@ unpkUniqueGrimly (MkUnique u)
    376 376 
             i   = u .&. uniqueMask
    377 377 
         in
    378 378 
         (tag, i)
    379 
    -{-# INLINE unpkUniqueGrimly #-}
    379 
    +{-# INLINE unpkUniqueGrimily #-}
    380 380
    381 381
    382 
    -unpkUnique u = case unpkUniqueGrimly u of
    382 
    +unpkUnique u = case unpkUniqueGrimily u of
    383 383 
       (c, i) -> ( charToUniqueTag c, i)
    384 384 
     {-# INLINE unpkUnique #-}
    385 385
    ... ... @@ -389,7 +389,7 @@ unpkUnique u = case unpkUniqueGrimly u of
    389 389 
     -- See Note [Symbol table representation of names] in "GHC.Iface.Binary" for details.
    390 390 
     isValidKnownKeyUnique :: Unique -> Bool
    391 391 
     isValidKnownKeyUnique u =
    392 
    -    case unpkUniqueGrimly u of
    392 
    +    case unpkUniqueGrimily u of
    393 393 
           (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22)
    394 394
    395 395 
     {-
    ... ... @@ -512,7 +512,7 @@ showUnique :: Unique -> String
    512 512 
     showUnique uniq
    513 513 
       = tagStr ++ w64ToBase62 u
    514 514 
       where
    515 
    -    (tag, u) = unpkUniqueGrimly uniq
    515 
    +    (tag, u) = unpkUniqueGrimily uniq
    516 516 
         -- Avoid emitting non-printable characters in pretty uniques.
    517 517 
         -- See #25989.
    518 518 
         tagStr

  • compiler/GHC/Types/Unique/Supply.hs
    ... ... @@ -16,10 +16,10 @@ module GHC.Types.Unique.Supply (
    16 16 
             -- ** Operations on supplies
    17 17 
             uniqFromSupply, uniqsFromSupply, -- basic ops
    18 18 
             takeUniqFromSupply,
    19 
    -        uniqFromTag, uniqFromTagGrimly,
    19 
    +        uniqFromTag, uniqFromTagGrimily,
    20 20 
             UniqueTag(..),
    21 21
    22 
    -        mkSplitUniqSupply, mkSplitUniqSupplyGrimly,
    22 
    +        mkSplitUniqSupply, mkSplitUniqSupplyGrimily,
    23 23 
             splitUniqSupply, listSplitUniqSupply,
    24 24
    25 25 
             -- * Unique supply monad and its abstraction
    ... ... @@ -203,10 +203,10 @@ data UniqSupply
    203 203 
                                     -- when split => these two supplies
    204 204
    205 205 
     mkSplitUniqSupply  :: UniqueTag -> IO UniqSupply
    206 
    -mkSplitUniqSupply ut = mkSplitUniqSupplyGrimly (uniqueTag ut)
    206 
    +mkSplitUniqSupply ut = mkSplitUniqSupplyGrimily (uniqueTag ut)
    207 207 
     {-# INLINE mkSplitUniqSupply #-}
    208 208
    209 
    -mkSplitUniqSupplyGrimly :: Char -> IO UniqSupply
    209 
    +mkSplitUniqSupplyGrimily :: Char -> IO UniqSupply
    210 210 
     -- ^ Create a unique supply out of thin air.
    211 211 
     -- The "tag" (Char) supplied is mostly cosmetic, making it easier
    212 212 
     -- to figure out where a Unique was born. See Note [Uniques and tags].
    ... ... @@ -219,7 +219,7 @@ mkSplitUniqSupplyGrimly :: Char -> IO UniqSupply
    219 219
    220 220 
     -- See Note [How the unique supply works]
    221 221 
     -- See Note [Optimising the unique supply]
    222 
    -mkSplitUniqSupplyGrimly ut
    222 
    +mkSplitUniqSupplyGrimily ut
    223 223 
       = unsafeDupableInterleaveIO (IO mk_supply)
    224 224
    225 225 
       where
    ... ... @@ -286,15 +286,15 @@ initUniqSupply counter inc = do
    286 286 
         poke ghc_unique_inc       inc
    287 287
    288 288 
     uniqFromTag :: UniqueTag -> IO Unique
    289 
    -uniqFromTag !ut = uniqFromTagGrimly (uniqueTag ut)
    289 
    +uniqFromTag !ut = uniqFromTagGrimily (uniqueTag ut)
    290 290
    291 291 
     {-# INLINE uniqFromTag #-}
    292 292
    293 
    -uniqFromTagGrimly :: Char -> IO Unique
    294 
    -uniqFromTagGrimly !tag
    293 
    +uniqFromTagGrimily :: Char -> IO Unique
    294 
    +uniqFromTagGrimily !tag
    295 295 
       = do { uqNum <- genSym
    296 296 
            ; return $! mkUniqueGrimilyWithTag tag uqNum }
    297 
    -{-# NOINLINE uniqFromTagGrimly #-} -- We'll unbox everything, but we don't want to inline it
    297 
    +{-# NOINLINE uniqFromTagGrimily #-} -- We'll unbox everything, but we don't want to inline it
    298 298
    299 299 
     splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
    300 300 
     -- ^ Build two 'UniqSupply' from a single one, each of which

  • testsuite/tests/ghc-api/T27273.hs
    1 
    +module Main where
    2 
    +
    3 
    +-- base
    4 
    +import Control.Monad
    5 
    +import Control.Monad.IO.Class (liftIO)
    6 
    +import System.Environment (getArgs)
    7 
    +
    8 
    +-- time
    9 
    +import Data.Time (getCurrentTime)
    10 
    +
    11 
    +-- ghc
    12 
    +import qualified GHC as GHC
    13 
    +import qualified GHC.Core as GHC
    14 
    +import qualified GHC.Data.StringBuffer as GHC
    15 
    +import qualified GHC.Unit.Module.ModGuts as GHC
    16 
    +import qualified GHC.Unit.Types as GHC
    17 
    +
    18 
    +--------------------------------------------------------------------------------
    19 
    +
    20 
    +main :: IO ()
    21 
    +main = do
    22 
    +    let inputSource = unlines
    23 
    +          [ "module NumLitDesugaring where"
    24 
    +          , "f :: Num a => a" -- !!! Succeeds if type signature is f :: Int
    25 
    +          , "f = 1"
    26 
    +          ]
    27 
    +
    28 
    +    void $ compileToCore "NumLitDesugaring" inputSource
    29 
    +
    30 
    +compileToCore :: String -> String -> IO [GHC.CoreBind]
    31 
    +compileToCore modName inputSource = do
    32 
    +    [libdir] <- getArgs
    33 
    +    GHC.runGhc (Just libdir) $ do
    34 
    +      (_ms, tcMod) <- typecheckSourceCode modName inputSource
    35 
    +      dsMod <- GHC.desugarModule tcMod
    36 
    +      return $ GHC.mg_binds $ GHC.dm_core_module dsMod
    37 
    +
    38 
    +typecheckSourceCode
    39 
    +  :: GHC.GhcMonad m => String -> String -> m (GHC.ModSummary, GHC.TypecheckedModule)
    40 
    +typecheckSourceCode modName inputSource = do
    41 
    +    now <- liftIO getCurrentTime
    42 
    +    df1 <- GHC.getSessionDynFlags
    43 
    +    GHC.setSessionDynFlags $ df1 { GHC.backend = GHC.bytecodeBackend }
    44 
    +    let target = GHC.Target
    45 
    +               { GHC.targetId           = GHC.TargetFile (modName ++ ".hs") Nothing
    46 
    +               , GHC.targetUnitId       = GHC.homeUnitId_ df1
    47 
    +               , GHC.targetAllowObjCode = False
    48 
    +               , GHC.targetContents     = Just (GHC.stringToStringBuffer inputSource, now)
    49 
    +               }
    50 
    +    GHC.setTargets [target]
    51 
    +    void $ GHC.depanal [] False
    52 
    +
    53 
    +    ms <- GHC.getModSummary
    54 
    +            (GHC.mkModule GHC.mainUnit (GHC.mkModuleName modName))
    55 
    +    tm <- GHC.parseModule ms >>= GHC.typecheckModule GHC.NoTcMPlugins
    56 
    +    return (ms, tm)

  • testsuite/tests/ghc-api/all.T
    ... ... @@ -82,3 +82,6 @@ test('TypeMapStringLiteral', normal, compile_and_run, ['-package ghc'])
    82 82
    83 83 
     test('T25121_status', normal, compile_and_run, ['-package ghc'])
    84 84 
     test('T24386', [extra_run_opts(f'"{config.libdir}"')], compile_and_run, ['-package ghc'])
    85 
    +test('T27273', [extra_run_opts(f'"{config.libdir}"')],
    86 
    +               compile_and_run,
    87 
    +               ['-package ghc'])

  • utils/ghc-pkg/Main.hs
    ... ... @@ -1826,7 +1826,7 @@ checkConsistency verbosity my_flags = do
    1826 1826 
                   all_ps = map mungedId pkgs1
    1827 1827
    1828 1828 
       let not_broken_pkgs = filterOut broken_pkgs pkgs
    1829 
    -      (_, trans_broken_pkgs) = closure [] not_broken_pkgs
    1829 
    +      trans_broken_pkgs = brokenPackages not_broken_pkgs
    1830 1830
    1831 1831 
           all_broken_pkgs :: [InstalledPackageInfo]
    1832 1832 
           all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
    ... ... @@ -1845,26 +1845,26 @@ checkConsistency verbosity my_flags = do
    1845 1845 
       when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
    1846 1846
    1847 1847
    1848 
    -closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
    1849 
    -        -> ([InstalledPackageInfo], [InstalledPackageInfo])
    1850 
    -closure pkgs db_stack = go pkgs db_stack
    1851 
    - where
    1852 
    -   go avail not_avail =
    1853 
    -     case partition (depsAvailable avail) not_avail of
    1854 
    -        ([],        not_avail') -> (avail, not_avail')
    1855 
    -        (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
    1848 
    +-- | Compute the set of transitive broken packages.
    1849 
    +--
    1850 
    +-- A package is assumed to be broken if any of its dependencies is not
    1851 
    +-- found in the 'db_stack' after a transitive reduction.
    1852 
    +brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
    1853 
    +brokenPackages db_stack = go Set.empty db_stack
    1854 
    +  where
    1855 
    +    go avail_ids not_avail =
    1856 
    +      case partition (depsAvailable avail_ids) not_avail of
    1857 
    +        ([],        not_avail') -> not_avail'
    1858 
    +        (new_avail, not_avail') -> go (add new_avail avail_ids) not_avail'
    1856 1859
    1857 
    -   depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
    1858 
    -                 -> Bool
    1859 
    -   depsAvailable pkgs_ok pkg = null dangling
    1860 
    -        where dangling = filter (`notElem` pids) (depends pkg)
    1861 
    -              pids = map installedUnitId pkgs_ok
    1860 
    +    add new_avail avail_ids =
    1861 
    +      foldl' (flip Set.insert) avail_ids (map installedUnitId new_avail)
    1862 1862
    1863 
    -        -- we want mutually recursive groups of package to show up
    1864 
    -        -- as broken. (#1750)
    1863 
    +    depsAvailable :: Set.Set UnitId -> InstalledPackageInfo -> Bool
    1864 
    +    depsAvailable pids pkg = all (`Set.member` pids) (depends pkg)
    1865 1865
    1866 
    -brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
    1867 
    -brokenPackages pkgs = snd (closure [] pkgs)
    1866 
    +      -- we want mutually recursive groups of package to show up
    1867 
    +      -- as broken. (#1750)
    1868 1868
    1869 1869 
     -----------------------------------------------------------------------------
    1870 1870 
     -- Sanity-check a new package config, and automatically build GHCi libs

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